*IF DEF,FLUXPROC FPCLMTIM.2
C ******************************COPYRIGHT****************************** FPCLMTIM.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPCLMTIM.4
C FPCLMTIM.5
C Use, duplication or disclosure of this code is subject to the FPCLMTIM.6
C restrictions as set forth in the contract. FPCLMTIM.7
C FPCLMTIM.8
C Meteorological Office FPCLMTIM.9
C London Road FPCLMTIM.10
C BRACKNELL FPCLMTIM.11
C Berkshire UK FPCLMTIM.12
C RG12 2SZ FPCLMTIM.13
C FPCLMTIM.14
C If no contract has been raised with this copy of the code, the use, FPCLMTIM.15
C duplication or disclosure of it is strictly prohibited. Permission FPCLMTIM.16
C to do so must first be obtained in writing from the Head of Numerical FPCLMTIM.17
C Modelling at the above address. FPCLMTIM.18
C ******************************COPYRIGHT****************************** FPCLMTIM.19
C FPCLMTIM.20
C Programming standard: Unified Model Documentation Paper No 3 FPCLMTIM.21
C Version No 1 15/1/90 FPCLMTIM.22
C History: FPCLMTIM.23
C version date change FPCLMTIM.24
C 4.5 03/09/98 New code FPCLMTIM.25
C FPCLMTIM.26
! Author: M. J. Bell FPCLMTIM.27
!---------------------------------------------------------------------- FPCLMTIM.28
! contains routines: set_climate_times FPCLMTIM.29
! FPCLMTIM.30
! Purpose: Flux processing routine. FPCLMTIM.31
! Preliminaries for interpolating climate fields in time FPCLMTIM.32
! sets date/times required to extract two climate fields FPCLMTIM.33
! and calculates the weights to give to them FPCLMTIM.34
! FPCLMTIM.35
! WARNING: does not test ICODE properly yet FPCLMTIM.36
!---------------------------------------------------------------------- FPCLMTIM.37
subroutine set_climate_times ( stcode, 1,6FPCLMTIM.38
*CALL AVALTIM 
FPCLMTIM.39
*CALL ACLM1TIM FPCLMTIM.40
*CALL ACLM2TIM FPCLMTIM.41
# weight1, weight2, icode ) FPCLMTIM.42
FPCLMTIM.43
implicit none FPCLMTIM.44
FPCLMTIM.45
! declaration of argument list FPCLMTIM.46
FPCLMTIM.47
integer stcode ! IN stash code of field being accessed FPCLMTIM.48
! validity time of field (intent: IN) FPCLMTIM.49
*CALL CVALTIM FPCLMTIM.50
! validity time (in lookup headers) of climate fields (intent: OUT) FPCLMTIM.51
*CALL CCLM1TIM FPCLMTIM.52
*CALL CCLM2TIM FPCLMTIM.53
real weight1 ! OUT weight to give to climate field 1 FPCLMTIM.54
real weight2 ! OUT weight to give to climate field 2 FPCLMTIM.55
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPCLMTIM.56
FPCLMTIM.57
! no parameters FPCLMTIM.58
FPCLMTIM.59
! declaration of globals used FPCLMTIM.60
*CALL CUNITNOS FPCLMTIM.61
*CALL CMESS FPCLMTIM.62
FPCLMTIM.63
! no local arrays FPCLMTIM.64
FPCLMTIM.65
! declaration of local scalars FPCLMTIM.66
! mid_month_day_# is day number of middle of month determined from FPCLMTIM.67
! lookup tables of climate file FPCLMTIM.68
integer mid_month_day_valid ! for validity time FPCLMTIM.69
integer mid_month_day_clim1 ! for climate field 1 FPCLMTIM.70
integer mid_month_day_clim2 ! for climate field 2 FPCLMTIM.71
integer Year1 ! year for climate field 1 FPCLMTIM.72
integer Year2 ! year for climate field 2 FPCLMTIM.73
integer CDay ! century day FPCLMTIM.74
integer C1Hour ! century hour of climate field 1 FPCLMTIM.75
integer C2Hour ! century hour of climate field 2 FPCLMTIM.76
integer ValHour ! century hour of validity time FPCLMTIM.77
FPCLMTIM.78
external climate_month_date, date31 FPCLMTIM.79
!---------------------------------------------------------------------- FPCLMTIM.80
! 0. Preliminaries FPCLMTIM.81
CSub = 'set_climate_times' ! subroutine name for error messages FPCLMTIM.82
FPCLMTIM.83
! 1. calculate the mid-month day of the validity time FPCLMTIM.84
FPCLMTIM.85
call climate_month_date( stcode, ValidMonth, FPCLMTIM.86
*CALL ACLM1TIM FPCLMTIM.87
# mid_month_day_valid, icode ) FPCLMTIM.88
FPCLMTIM.89
FPCLMTIM.90
! 2. determine the months of the first and second climate fields to use FPCLMTIM.91
FPCLMTIM.92
if ( ValidDay .gt. mid_month_day_valid ) then FPCLMTIM.93
Clim1Month = ValidMonth FPCLMTIM.94
else FPCLMTIM.95
Clim1Month = ValidMonth - 1 FPCLMTIM.96
end if FPCLMTIM.97
FPCLMTIM.98
if ( Clim1Month .eq. 0) then FPCLMTIM.99
Clim1Month = 12 FPCLMTIM.100
end if FPCLMTIM.101
FPCLMTIM.102
Clim2Month = Clim1Month + 1 FPCLMTIM.103
FPCLMTIM.104
if ( Clim2Month .eq. 13) then FPCLMTIM.105
Clim2Month = 1 FPCLMTIM.106
end if FPCLMTIM.107
FPCLMTIM.108
! 3. find mid-month days of the first and second climate months FPCLMTIM.109
! and the full dates in the lookup tables for these fields (one FPCLMTIM.110
! of the main outputsfrom this routine) FPCLMTIM.111
FPCLMTIM.112
call climate_month_date( stcode, Clim1Month, FPCLMTIM.113
*CALL ACLM1TIM FPCLMTIM.114
# mid_month_day_clim1,icode ) FPCLMTIM.115
FPCLMTIM.116
call climate_month_date( stcode, Clim2Month, FPCLMTIM.117
*CALL ACLM2TIM FPCLMTIM.118
# mid_month_day_clim2,icode ) FPCLMTIM.119
FPCLMTIM.120
! 4. find the weights to give two months when interpolating to FPCLMTIM.121
! validity time FPCLMTIM.122
FPCLMTIM.123
! 4.1 find the years for months 1 and 2 FPCLMTIM.124
FPCLMTIM.125
if ( Clim1Month .eq. 12 .and. ValidMonth .eq. 1 ) then FPCLMTIM.126
Year1 = ValidYear - 1 FPCLMTIM.127
else FPCLMTIM.128
Year1 = ValidYear FPCLMTIM.129
end if FPCLMTIM.130
FPCLMTIM.131
if ( Clim2Month .eq. 1 .and. ValidMonth .eq. 12 ) then FPCLMTIM.132
Year2 = ValidYear + 1 FPCLMTIM.133
else FPCLMTIM.134
Year2 = ValidYear FPCLMTIM.135
end if FPCLMTIM.136
FPCLMTIM.137
! 4.2 find the relative times (in hours) of the three dates FPCLMTIM.138
FPCLMTIM.139
call date31(mid_month_day_clim1, Clim1Month, Year1,CDay) FPCLMTIM.140
C1Hour = (CDay-1)*24 FPCLMTIM.141
FPCLMTIM.142
call date31(mid_month_day_clim2, Clim2Month, Year2,CDay) FPCLMTIM.143
C2Hour = (CDay-1)*24 FPCLMTIM.144
FPCLMTIM.145
call date31(ValidDay, ValidMonth, ValidYear,CDay) FPCLMTIM.146
ValHour = (CDay-1)*24 + ValidHour FPCLMTIM.147
FPCLMTIM.148
! 4.3 calculate the weights FPCLMTIM.149
weight1 = real( C2Hour - ValHour ) / real( C2Hour - C1Hour ) FPCLMTIM.150
weight2 = 1.0 - weight1 FPCLMTIM.151
FPCLMTIM.152
9999 continue FPCLMTIM.153
return FPCLMTIM.154
end FPCLMTIM.155
!---------------------------------------------------------------------- FPCLMTIM.156
*ENDIF FPCLMTIM.157