subroutine read_climate_field(StCode, IVTOffHr, 8,6FPRDCLM1.36
# ldebug, Int_Head, Real_Head, FPRDCLM1.37
# ncols, nrows, field, FPRDCLM1.38
*CALL ARGPPX 
FPRDCLM1.39
# icode) FPRDCLM1.40
FPRDCLM1.41
implicit none FPRDCLM1.42
FPRDCLM1.43
! declaration of parameters FPRDCLM1.44
*CALL CSUBMODL FPRDCLM1.45
*CALL CPPXREF FPRDCLM1.46
*CALL PPXLOOK FPRDCLM1.47
*CALL CLOOKADD FPRDCLM1.48
*CALL PLOOKUPS FPRDCLM1.49
*CALL C_MDI FPRDCLM1.50
FPRDCLM1.51
! declaration of argument list FPRDCLM1.52
FPRDCLM1.53
! user's search criteria FPRDCLM1.54
integer StCode ! IN FPRDCLM1.55
integer IVTOffHr ! IN offset from validity time in hours FPRDCLM1.56
FPRDCLM1.57
! debug control variable FPRDCLM1.58
logical ldebug ! IN T => output debugging info FPRDCLM1.59
logical l_climate_field ! Set to true if reading climate field FPRDCLM1.60
FPRDCLM1.61
! lookup tables FPRDCLM1.62
integer Int_Head(Len_IntHd) ! OUT FPRDCLM1.63
real Real_Head(Len_RealHd) ! OUT FPRDCLM1.64
FPRDCLM1.65
! output field FPRDCLM1.66
integer ncols ! IN number of columns FPRDCLM1.67
integer nrows ! IN number of rows FPRDCLM1.68
real field(ncols,nrows) ! OUT field values FPRDCLM1.69
FPRDCLM1.70
! error code FPRDCLM1.71
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPRDCLM1.72
FPRDCLM1.73
FPRDCLM1.74
! declaration of globals used FPRDCLM1.75
*CALL CUNITNOS FPRDCLM1.76
*CALL CMESS FPRDCLM1.77
FPRDCLM1.78
*CALL CLOOKUPS FPRDCLM1.79
FPRDCLM1.80
*CALL CREFTIM FPRDCLM1.81
*CALL CVALTIM FPRDCLM1.82
*CALL CCLM1TIM FPRDCLM1.83
*CALL CCLM2TIM FPRDCLM1.84
FPRDCLM1.85
! declaration of local arrays FPRDCLM1.86
real field1(ncols,nrows) ! values from earlier climate field FPRDCLM1.87
real field2(ncols,nrows) ! values from later climate field FPRDCLM1.88
FPRDCLM1.89
! declaration of local scalars FPRDCLM1.90
real weight1 ! weight to give to 1st climate field FPRDCLM1.91
real weight2 ! weight to give to 2nd climate field FPRDCLM1.92
FPRDCLM1.93
! declaration of externals FPRDCLM1.94
external add_hours, read_one_field, set_climate_times, FPRDCLM1.95
# interp_time FPRDCLM1.96
!---------------------------------------------------------------------- FPRDCLM1.97
! 0. Preliminaries FPRDCLM1.98
CSub = 'read_climate_field' ! subroutine name for error messages FPRDCLM1.99
l_climate_field = .true. FPRDCLM1.100
FPRDCLM1.101
if (LClimate) then FPRDCLM1.102
FPRDCLM1.103
! 1. calculate validity time of NWP data required FPRDCLM1.104
FPRDCLM1.105
call add_hours( FPRDCLM1.106
*CALL AREFTIM FPRDCLM1.107
*CALL AVALTIM FPRDCLM1.108
# IVTOffHr) FPRDCLM1.109
FPRDCLM1.110
FPRDCLM1.111
! 2. set up times of fields to look for and FPRDCLM1.112
! time interpolation coefficients FPRDCLM1.113
FPRDCLM1.114
call set_climate_times ( StCode, FPRDCLM1.115
*CALL AVALTIM FPRDCLM1.116
*CALL ACLM1TIM FPRDCLM1.117
*CALL ACLM2TIM FPRDCLM1.118
# weight1, weight2, icode ) FPRDCLM1.119
FPRDCLM1.120
if ( icode .gt. 0) then FPRDCLM1.121
write(UnWarn,*)CWarn//CSub// FPRDCLM1.122
# '2. failed setting climate times', FPRDCLM1.123
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDCLM1.124
go to 9999 FPRDCLM1.125
end if FPRDCLM1.126
FPRDCLM1.127
! 3. Extract climate field before validity time FPRDCLM1.128
FPRDCLM1.129
call read_one_field (UnitClimate, ITEM_CODE, Stcode, FPRDCLM1.130
*CALL ACLM1TIM FPRDCLM1.131
# Len_FixHd, FixHdClimate, Len1_Lookup, FPRDCLM1.132
# Len2_ActualClimate, LookupClimate, LookFldNoClimate, FPRDCLM1.133
# ldebug, l_climate_field, FPRDCLM1.134
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDCLM1.135
# ncols, nrows, field1, FPRDCLM1.136
*CALL ARGPPX FPRDCLM1.137
# icode) FPRDCLM1.138
FPRDCLM1.139
FPRDCLM1.140
if ( icode .gt. 0) then FPRDCLM1.141
write(UnWarn,*)CWarn//CSub// FPRDCLM1.142
# ' 3. failed reading 1st climate field', FPRDCLM1.143
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDCLM1.144
go to 9999 FPRDCLM1.145
end if FPRDCLM1.146
FPRDCLM1.147
! 4. Extract climate field after validity time FPRDCLM1.148
call read_one_field (UnitClimate, ITEM_CODE, Stcode, FPRDCLM1.149
*CALL ACLM2TIM FPRDCLM1.150
# Len_FixHd, FixHdClimate, Len1_Lookup, FPRDCLM1.151
# Len2_ActualClimate, LookupClimate, LookFldNoClimate, FPRDCLM1.152
# ldebug, l_climate_field, FPRDCLM1.153
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDCLM1.154
# ncols, nrows, field2, FPRDCLM1.155
*CALL ARGPPX FPRDCLM1.156
# icode) FPRDCLM1.157
FPRDCLM1.158
if ( icode .gt. 0) then FPRDCLM1.159
write(UnWarn,*)CWarn//CSub// FPRDCLM1.160
# '4. failed reading 2nd climate field', FPRDCLM1.161
# 'for stash code ', stcode, '; IVTOffHr = ', IVTOffHr FPRDCLM1.162
go to 9999 FPRDCLM1.163
end if FPRDCLM1.164
FPRDCLM1.165
! 5. If found: interpolate in time to validity time FPRDCLM1.166
FPRDCLM1.167
call interp_time(Int_Head, ncols, nrows, rmdi, FPRDCLM1.168
*CALL AVALTIM FPRDCLM1.169
# weight1, weight2, Field1, Field2, Field) FPRDCLM1.170
FPRDCLM1.171
! 6. Output standard message and exit routine FPRDCLM1.172
FPRDCLM1.173
write(UnStd,*)CStd//CSub//'climate field stcode ', FPRDCLM1.174
# stcode, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDCLM1.175
FPRDCLM1.176
! 7. Write times to integer headers FPRDCLM1.177
call amend_times ( FPRDCLM1.178
*CALL AVALTIM FPRDCLM1.179
# Int_Head,Len_IntHd ) FPRDCLM1.180
go to 9999 FPRDCLM1.181
FPRDCLM1.182
FPRDCLM1.183
! 7. Else If there is no climate file return an error code FPRDCLM1.184
FPRDCLM1.185
else ! LClimate FPRDCLM1.186
FPRDCLM1.187
icode = 7 FPRDCLM1.188
write(UnWarn,*)CWarn//CSub//'7. Climate file is not open,', FPRDCLM1.189
# ' so no climate data can be extracted.' FPRDCLM1.190
FPRDCLM1.191
end if ! LClimate FPRDCLM1.192
FPRDCLM1.193
9999 continue FPRDCLM1.194
return FPRDCLM1.195
end FPRDCLM1.196
!---------------------------------------------------------------------- FPRDCLM1.197
*ENDIF FPRDCLM1.198