*IF DEF,FLUXPROC FPCLMDT1.2
C ******************************COPYRIGHT****************************** FPCLMDT1.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPCLMDT1.4
C FPCLMDT1.5
C Use, duplication or disclosure of this code is subject to the FPCLMDT1.6
C restrictions as set forth in the contract. FPCLMDT1.7
C FPCLMDT1.8
C Meteorological Office FPCLMDT1.9
C London Road FPCLMDT1.10
C BRACKNELL FPCLMDT1.11
C Berkshire UK FPCLMDT1.12
C RG12 2SZ FPCLMDT1.13
C FPCLMDT1.14
C If no contract has been raised with this copy of the code, the use, FPCLMDT1.15
C duplication or disclosure of it is strictly prohibited. Permission FPCLMDT1.16
C to do so must first be obtained in writing from the Head of Numerical FPCLMDT1.17
C Modelling at the above address. FPCLMDT1.18
C ******************************COPYRIGHT****************************** FPCLMDT1.19
C FPCLMDT1.20
C Programming standard: Unified Model Documentation Paper No 3 FPCLMDT1.21
C Version No 1 15/1/90 FPCLMDT1.22
C History: FPCLMDT1.23
C version date change FPCLMDT1.24
C 4.5 03/09/98 New code FPCLMDT1.25
C FPCLMDT1.26
! Author: M. J. Bell FPCLMDT1.27
!---------------------------------------------------------------------- FPCLMDT1.28
! contains routines: climate_month_date FPCLMDT1.29
! FPCLMDT1.30
! Purpose: Flux processing routine. FPCLMDT1.31
! Calculates the full date of a climate field which matches FPCLMDT1.32
! the input stash code and month number. FPCLMDT1.33
! Also output the day of the middle of the month. FPCLMDT1.34
! FPCLMDT1.35
! WARNING: This routine contains mid_month_day_valid hard wired FPCLMDT1.36
! as 15 FPCLMDT1.37
!---------------------------------------------------------------------- FPCLMDT1.38
subroutine climate_month_date( stcode, ValidMonth, 3FPCLMDT1.39
*CALL ACLM1TIM 
FPCLMDT1.40
# mid_month_day_valid, icode) FPCLMDT1.41
FPCLMDT1.42
implicit none FPCLMDT1.43
FPCLMDT1.44
! declaration of argument list FPCLMDT1.45
integer stcode ! IN stash code of field to look for FPCLMDT1.46
integer ValidMonth ! IN month of field to look for FPCLMDT1.47
! validity time (in lookup header) of climate field (intent: OUT) FPCLMDT1.48
*CALL CCLM1TIM FPCLMDT1.49
integer mid_month_day_valid ! OUT day number of middle of month FPCLMDT1.50
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPCLMDT1.51
FPCLMDT1.52
! declaration of parameters FPCLMDT1.53
*CALL CLOOKADD FPCLMDT1.54
*CALL PLOOKUPS FPCLMDT1.55
FPCLMDT1.56
! declaration of globals used FPCLMDT1.57
*CALL CUNITNOS FPCLMDT1.58
*CALL CMESS FPCLMDT1.59
*CALL CLOOKUPS FPCLMDT1.60
FPCLMDT1.61
! no local arrays FPCLMDT1.62
FPCLMDT1.63
! declaration of local scalars FPCLMDT1.64
logical ItemFound ! T => item has been found FPCLMDT1.65
integer fld_no ! number of lookup table of required field FPCLMDT1.66
integer i ! do loop index for lookup table number FPCLMDT1.67
!---------------------------------------------------------------------- FPCLMDT1.68
! 0. Preliminaries FPCLMDT1.69
CSub = 'climate_month_date' ! subroutine name for error messages FPCLMDT1.70
FPCLMDT1.71
! 1. Find a match in the climate lookup tables FPCLMDT1.72
FPCLMDT1.73
ItemFound = .false. FPCLMDT1.74
do i = 1, Len2_ActualClimate FPCLMDT1.75
if ( LookupClimate(LBMON,i) .eq. ValidMonth .and. FPCLMDT1.76
# LookupClimate(ITEM_CODE,i) .eq. StCode ) then FPCLMDT1.77
ItemFound = .True. FPCLMDT1.78
fld_no = i FPCLMDT1.79
go to 100 FPCLMDT1.80
end if FPCLMDT1.81
end do FPCLMDT1.82
FPCLMDT1.83
100 continue FPCLMDT1.84
FPCLMDT1.85
if ( .not. ItemFound ) then FPCLMDT1.86
icode = 34 FPCLMDT1.87
write(UnWarn,*)CWarn,CSub, FPCLMDT1.88
# ' step 1. unable to find climate field with stcode ', stcode, FPCLMDT1.89
# ' for month ', ValidMonth FPCLMDT1.90
go to 9999 FPCLMDT1.91
end if FPCLMDT1.92
FPCLMDT1.93
FPCLMDT1.94
! 2. Set the date in CCLM1TIM from the lookup table FPCLMDT1.95
Clim1Year = LookupClimate(LBYR, fld_no) FPCLMDT1.96
Clim1Month = LookupClimate(LBMON, fld_no) FPCLMDT1.97
Clim1Day = LookupClimate(LBDAT, fld_no) FPCLMDT1.98
Clim1Hour = LookupClimate(LBHR, fld_no) FPCLMDT1.99
Clim1Min = LookupClimate(LBMIN, fld_no) FPCLMDT1.100
Clim1Sec = 0 FPCLMDT1.101
FPCLMDT1.102
! 3. Calculate the middle day in the month from the lookup table FPCLMDT1.103
FPCLMDT1.104
! if ( LookupClimate(LBDAT, fld_no) .eq. FPCLMDT1.105
! # LookupClimate(LBDATD, fld_no) ) then FPCLMDT1.106
! mid_month_day_valid = LookupClimate(LBDATD, fld_no) FPCLMDT1.107
FPCLMDT1.108
! else FPCLMDT1.109
! mid_month_day_valid = 0.5 * (LookupClimate(LBDATD,fld_no) + 1) FPCLMDT1.110
FPCLMDT1.111
! end if FPCLMDT1.112
FPCLMDT1.113
mid_month_day_valid = 15 FPCLMDT1.114
if ( mid_month_day_valid .lt. 14 .or. FPCLMDT1.115
# mid_month_day_valid .gt. 16 ) then FPCLMDT1.116
icode = 35 FPCLMDT1.117
write(UnWarn,*)CErr,CSub, FPCLMDT1.118
# ' step 3. Lookup table times for climate fields are strange ', FPCLMDT1.119
# ' mid_month_day_valid = ', mid_month_day_valid FPCLMDT1.120
go to 9999 FPCLMDT1.121
end if FPCLMDT1.122
FPCLMDT1.123
9999 continue FPCLMDT1.124
return FPCLMDT1.125
end FPCLMDT1.126
!---------------------------------------------------------------------- FPCLMDT1.127
*ENDIF FPCLMDT1.128