*IF DEF,C70_1A SETPERL1.2
C ******************************COPYRIGHT****************************** SETPERL1.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. SETPERL1.4
C SETPERL1.5
C Use, duplication or disclosure of this code is subject to the SETPERL1.6
C restrictions as set forth in the contract. SETPERL1.7
C SETPERL1.8
C Meteorological Office SETPERL1.9
C London Road SETPERL1.10
C BRACKNELL SETPERL1.11
C Berkshire UK SETPERL1.12
C RG12 2SZ SETPERL1.13
C SETPERL1.14
C If no contract has been raised with this copy of the code, the use, SETPERL1.15
C duplication or disclosure of it is strictly prohibited. Permission SETPERL1.16
C to do so must first be obtained in writing from the Head of Numerical SETPERL1.17
C Modelling at the above address. SETPERL1.18
C ******************************COPYRIGHT****************************** SETPERL1.19
C SETPERL1.20
!LL SUBROUTINE SETPERLEN--------------------------------------------- SETPERL1.21
!LL SETPERL1.22
!LL Purpose: SETPERL1.23
!LL Return length of current meaning period using mean-level SETPERL1.24
!LL (0, 1, 2 or 3) & current date. Days_in_month is declared SETPERL1.25
!LL and provided by comdeck CDAYDATA. SETPERL1.26
!LL SETPERL1.27
!LL Method: where this routine is called at the end of a month, the SETPERL1.28
!LL month will already have been incremented, which is why SETPERL1.29
!LL i_month-1 is used in setting the period length. Every SETPERL1.30
!LL 100 years is not leap unless year is divisible by 400. SETPERL1.31
!LL SETPERL1.32
! Current Code Owner: Mark Gallani SETPERL1.33
! SETPERL1.34
! History: SETPERL1.35
! Version Date Comment SETPERL1.36
! ======= ==== ======= SETPERL1.37
! 4.4 15/01/97 Original code. (Mark Gallani) SETPERL1.38
! SETPERL1.39
! Code description: SETPERL1.40
! FORTRAN 77 + common extensions also in Fortran 90 SETPERL1.41
!LL SETPERL1.42
!LL SETPERL1.43
!LL Programming standard : UMDP 3 Version 7 (rev. 6/10/94) SETPERL1.44
!LL SETPERL1.45
!LL Logical components covered : SETPERL1.46
!LL SETPERL1.47
!LL Project task : SETPERL1.48
!LL SETPERL1.49
!LL External documentation: SETPERL1.50
!LL SETPERL1.51
!LL----------------------------------------------------------------- SETPERL1.52
!*L Arguments:------------------------------------------------------ SETPERL1.53
SUBROUTINE SETPERLEN (MEANLEV,I_MONTH,I_YEAR,PERIODLEN) 2SETPERL1.54
SETPERL1.55
IMPLICIT NONE SETPERL1.56
SETPERL1.57
INTEGER SETPERL1.58
& MEANLEV, ! IN - Mean level indicator, e.g. 0, 1, 2 or 3 SETPERL1.59
& I_MONTH, ! IN - model time (month) SETPERL1.60
& I_YEAR, ! IN - model time (year) SETPERL1.61
& PERIODLEN ! OUT - length of current meaning period (days) SETPERL1.62
SETPERL1.63
!----------------------------------------------------------------------- SETPERL1.64
! Workspace usage:------------------------------------------------------ SETPERL1.65
! NONE SETPERL1.66
!----------------------------------------------------------------------- SETPERL1.67
! External subroutines called:------------------------------------------ SETPERL1.68
! NONE SETPERL1.69
!*---------------------------------------------------------------------- SETPERL1.70
! Define local variables:----------------------------------------------- SETPERL1.71
SETPERL1.72
LOGICAL L_LEAP ! Leap year indicator SETPERL1.73
SETPERL1.74
!----------------------------------------------------------------------- SETPERL1.75
! Comdecks: SETPERL1.76
*CALL CDAYDATA 
SETPERL1.77
!----------------------------------------------------------------------- SETPERL1.78
! End of standard header info SETPERL1.79
SETPERL1.80
IF (mod(i_year,4) .eq. 0 .AND. ! is this a leap year? SETPERL1.81
& (mod(i_year,400) .eq. 0 .OR. mod(i_year,100) .ne. 0)) then SETPERL1.82
L_LEAP = .TRUE. SETPERL1.83
ELSE SETPERL1.84
L_LEAP = .FALSE. SETPERL1.85
END IF SETPERL1.86
SETPERL1.87
IF (meanlev .eq. 0) then ! instantaneous data (e.g. part- SETPERL1.88
periodlen = 1 ! way through a monthly mean) SETPERL1.89
ELSEIF (meanlev .eq. 1) then ! end of monthly mean SETPERL1.90
IF (L_LEAP .AND. (i_month .eq. 3)) then ! Is it leap year Feb? SETPERL1.91
periodlen = days_in_month(i_month-1) + 1 SETPERL1.92
ELSE IF (i_month .eq. 1) then ! end of Dec, so can't use SETPERL1.93
periodlen = 31 ! days_in_month(i_month-1) SETPERL1.94
ELSE SETPERL1.95
periodlen = days_in_month(i_month-1) SETPERL1.96
END IF SETPERL1.97
ELSE IF (meanlev .eq. 2) then ! seasonal mean SETPERL1.98
SETPERL1.99
! find season length using current month as pointer SETPERL1.100
IF (L_LEAP) then ! do leap year seasons SETPERL1.101
IF (i_month .eq. 5) then ! season=FebMarApr SETPERL1.102
periodlen = 90 SETPERL1.103
ELSE IF ((i_month .eq. 3) .or. (i_month .eq. 4) .or. SETPERL1.104
& (i_month .eq. 7) .or. (i_month .eq. 12)) then SETPERL1.105
periodlen = 91 ! for DJF, JFM, AMJ or SON SETPERL1.106
ELSE SETPERL1.107
periodlen = 92 SETPERL1.108
END IF SETPERL1.109
ELSE ! do non-leap year seasons SETPERL1.110
IF (i_month .eq. 5) then ! season=FebMarApr SETPERL1.111
periodlen = 89 SETPERL1.112
ELSE IF ((i_month .eq. 3) .or. (i_month .eq. 4)) then SETPERL1.113
periodlen = 90 ! for DJF and JFM SETPERL1.114
ELSE IF ((i_month .eq. 7) .or. (i_month .eq. 12)) then SETPERL1.115
periodlen = 91 ! for AMJ and SON SETPERL1.116
ELSE SETPERL1.117
periodlen = 92 ! for all other seasons SETPERL1.118
END IF SETPERL1.119
END IF ! end of IF test of L_LEAP, and end of seasons. SETPERL1.120
ELSE IF (meanlev .eq. 3) then ! annual mean SETPERL1.121
SETPERL1.122
! Bear in mind period 3 may be 366 days if _previous_ year was leap, and SETPERL1.123
! may not always be 366 days even if current year is a leap year, since SETPERL1.124
! annual means are often not for calendar years SETPERL1.125
IF (L_LEAP .AND. (i_month .ne. 2)) then SETPERL1.126
periodlen = 366 SETPERL1.127
ELSE IF (mod(i_year-1,4) .eq. 0 .AND. ! was last year leap? SETPERL1.128
& (mod(i_year-1,400) .eq. 0 .OR. mod(i_year-1,100) .ne. 0)) then SETPERL1.129
IF (i_month .eq. 2) then SETPERL1.130
periodlen = 366 SETPERL1.131
ENDIF SETPERL1.132
ELSE SETPERL1.133
periodlen = 365 SETPERL1.134
ENDIF SETPERL1.135
ELSE ! meanlev has unexpected value SETPERL1.136
periodlen = 1 ! so set weighting factor=1 SETPERL1.137
write(6,*)'SETPERLEN: MEANLEV not in allowed range of 0 to 3' SETPERL1.138
END IF ! end of IF tests on meanlev SETPERL1.139
SETPERL1.140
RETURN SETPERL1.141
END SETPERL1.142
SETPERL1.143
*ENDIF SETPERL1.144