subroutine read_accum_flds(StCode, IVTOffHr, 8,18FPRDACC1.39
# ldebug, Int_Head, Real_Head, FPRDACC1.40
# ncols, nrows, field, FPRDACC1.41
*CALL ARGPPX 
FPRDACC1.42
# icode) FPRDACC1.43
FPRDACC1.44
implicit none FPRDACC1.45
FPRDACC1.46
! declaration of parameters FPRDACC1.47
*CALL CSUBMODL FPRDACC1.48
*CALL CPPXREF FPRDACC1.49
*CALL PPXLOOK FPRDACC1.50
*CALL CLOOKADD FPRDACC1.51
*CALL PLOOKUPS FPRDACC1.52
*CALL CVALOFF FPRDACC1.53
real time ! timescale in seconds for division FPRDACC1.54
!(SAS)**** parameter ( time = 21600 ) FPRDACC1.55
FPRDACC1.56
! declaration of argument list FPRDACC1.57
FPRDACC1.58
! search criteria FPRDACC1.59
FPRDACC1.60
! Uses StCode to read NWP files FPRDACC1.61
! stcode to read climate fields FPRDACC1.62
integer StCode ! IN StCode value to test FPRDACC1.63
FPRDACC1.64
! Reference date is used with IVTOffHr to define validity FPRDACC1.65
! time needed FPRDACC1.66
integer IVTOffHr ! IN offset from validity time in hours FPRDACC1.67
FPRDACC1.68
! debug control variable FPRDACC1.69
logical ldebug ! IN T => output debugging info FPRDACC1.70
logical l_climate_field ! Set to false initially FPRDACC1.71
FPRDACC1.72
! lookup tables FPRDACC1.73
integer Int_Head(Len_IntHd) ! OUT FPRDACC1.74
real Real_Head(Len_RealHd) ! OUT FPRDACC1.75
FPRDACC1.76
! output field FPRDACC1.77
integer ncols ! IN number of columns FPRDACC1.78
integer nrows ! IN number of rows FPRDACC1.79
real field(ncols,nrows) ! OUT field values FPRDACC1.80
FPRDACC1.81
! error code FPRDACC1.82
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPRDACC1.83
FPRDACC1.84
FPRDACC1.85
! declaration of globals used FPRDACC1.86
*CALL CUNITNOS FPRDACC1.87
*CALL CMESS FPRDACC1.88
*CALL C_MDI FPRDACC1.89
*CALL CLOOKUPS FPRDACC1.90
FPRDACC1.91
*CALL CREFTIM FPRDACC1.92
*CALL CVALTIM FPRDACC1.93
FPRDACC1.94
FPRDACC1.95
! declaration of local arrays FPRDACC1.96
real fieldVT(ncols,nrows) ! field at validity time FPRDACC1.97
real fieldM6(ncols,nrows) ! field at validity time minus 6 hours FPRDACC1.98
real fieldint(ncols,nrows) ! intermediate field for calculation FPRDACC1.99
FPRDACC1.100
! declaration of local scalars FPRDACC1.101
real timediv ! division scale for field (6x3600) FPRDACC1.102
integer IM6OffHr ! secondary validity time offset for VT-6 FPRDACC1.103
FPRDACC1.104
! declaration of logicals FPRDACC1.105
logical l_preferred_VT ! OUT test for preferred field at VT FPRDACC1.106
logical l_preferred_M6 ! OUT test for preferred field at VT-6 FPRDACC1.107
logical l_previous_VT ! OUT test for previous field at VT FPRDACC1.108
logical l_previous_M6 ! OUT test for previous field at VT-6 FPRDACC1.109
FPRDACC1.110
character *256 cmessage ! error message FPRDACC1.111
FPRDACC1.112
FPRDACC1.113
FPRDACC1.114
! declaration of externals FPRDACC1.115
external add_hours, read_one_field, read_climate_field, FPRDACC1.116
# FieldSub,ScalarMult,check_header FPRDACC1.117
FPRDACC1.118
FPRDACC1.119
!---------------------------------------------------------------------- FPRDACC1.120
! 0. Preliminaries FPRDACC1.121
CSub = 'read_accum_flds' ! subroutine name for error messages FPRDACC1.122
l_preferred_M6 = .false. FPRDACC1.123
l_preferred_VT = .false. FPRDACC1.124
l_previous_M6 = .false. FPRDACC1.125
l_previous_VT = .false. FPRDACC1.126
l_climate_field = .false. FPRDACC1.127
FPRDACC1.128
time = ValidityPeriod * 3600 FPRDACC1.129
FPRDACC1.130
! 1. calculate validity time minus 6 hours of NWP data required FPRDACC1.131
IM6OffHr = IVTOffHr - ValidityPeriod FPRDACC1.132
call add_hours( FPRDACC1.133
*CALL AREFTIM FPRDACC1.134
*CALL AVALTIM FPRDACC1.135
# IM6OffHr) FPRDACC1.136
FPRDACC1.137
!---------------------------------------------------------------------- FPRDACC1.138
! 2. Check headers for preferred and previous to see if they exist FPRDACC1.139
!---------------------------------------------------------------------- FPRDACC1.140
if ( LPreferred ) then FPRDACC1.141
call check_header (StCode,Len1_Lookup, FPRDACC1.142
# Len2_ActualPreferred, FPRDACC1.143
# LookupPreferred, FPRDACC1.144
*CALL AVALTIM FPRDACC1.145
# l_preferred_M6) FPRDACC1.146
endif FPRDACC1.147
if ( LPrevious ) then FPRDACC1.148
call check_header (StCode,Len1_Lookup, FPRDACC1.149
# Len2_ActualPrevious, FPRDACC1.150
# LookupPrevious, FPRDACC1.151
*CALL AVALTIM FPRDACC1.152
# l_previous_M6) FPRDACC1.153
endif FPRDACC1.154
FPRDACC1.155
! 2.1 Calculate Validity Time and check if VT exists FPRDACC1.156
call add_hours( FPRDACC1.157
*CALL AREFTIM FPRDACC1.158
*CALL AVALTIM FPRDACC1.159
# IVTOffHr) FPRDACC1.160
if ( LPreferred) then FPRDACC1.161
call check_header (StCode,Len1_Lookup, FPRDACC1.162
# Len2_ActualPreferred, FPRDACC1.163
# LookupPreferred, FPRDACC1.164
*CALL AVALTIM FPRDACC1.165
# l_preferred_VT) FPRDACC1.166
endif FPRDACC1.167
if ( LPrevious ) then FPRDACC1.168
call check_header (StCode,Len1_Lookup, FPRDACC1.169
# Len2_ActualPrevious, FPRDACC1.170
# LookupPrevious, FPRDACC1.171
*CALL AVALTIM FPRDACC1.172
# l_previous_VT) FPRDACC1.173
endif FPRDACC1.174
FPRDACC1.175
!---------------------------------------------------------------------- FPRDACC1.176
! 3. Read preferred VT&VT-6 if they exist else previous if they do FPRDACC1.177
!---------------------------------------------------------------------- FPRDACC1.178
if ( l_preferred_M6 .and. l_preferred_VT ) then FPRDACC1.179
call read_one_field (UnitPreferred, ITEM_CODE, StCode, FPRDACC1.180
*CALL AVALTIM FPRDACC1.181
# Len_FixHd, FixHdPreferred,Len1_Lookup, FPRDACC1.182
# Len2_ActualPreferred, LookupPreferred, LookFldNoPreferred, FPRDACC1.183
# ldebug, l_climate_field, FPRDACC1.184
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDACC1.185
# ncols, nrows, fieldVT, FPRDACC1.186
*CALL ARGPPX FPRDACC1.187
# icode) FPRDACC1.188
FPRDACC1.189
if ( icode .le. 0) then FPRDACC1.190
! 3.1 if successful, issue standard message and exit routine FPRDACC1.191
write(UnStd,*)CStd//CSub// FPRDACC1.192
# 'NWP preferred field (VT) StCode ', FPRDACC1.193
# StCode, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDACC1.194
else FPRDACC1.195
! 3.2 else write warning message and reset icode FPRDACC1.196
write(UnWarn,*)CWarn//CSub// FPRDACC1.197
# 'NWP preferred field (VT) StCode ', FPRDACC1.198
# StCode, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDACC1.199
l_preferred_VT = .false. FPRDACC1.200
end if FPRDACC1.201
icode = 0 ! reset icode FPRDACC1.202
FPRDACC1.203
! 3.3 If preferred VT has been read, then read preferred VT-6 FPRDACC1.204
if ( l_preferred_VT ) then FPRDACC1.205
call add_hours( FPRDACC1.206
*CALL AREFTIM FPRDACC1.207
*CALL AVALTIM FPRDACC1.208
# IM6OffHr) FPRDACC1.209
call read_one_field (UnitPreferred, ITEM_CODE, StCode, FPRDACC1.210
*CALL AVALTIM FPRDACC1.211
# Len_FixHd, FixHdPreferred,Len1_Lookup, FPRDACC1.212
# Len2_ActualPreferred, LookupPreferred, LookFldNoPreferred, FPRDACC1.213
# ldebug, l_climate_field, FPRDACC1.214
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDACC1.215
# ncols, nrows, fieldM6, FPRDACC1.216
*CALL ARGPPX FPRDACC1.217
# icode) FPRDACC1.218
FPRDACC1.219
if ( icode .le. 0) then FPRDACC1.220
! 3.4 if successful, issue standard message and exit routine FPRDACC1.221
write(UnStd,*)CStd//CSub// FPRDACC1.222
# 'NWP preferred field (VT-6) StCode ', FPRDACC1.223
# StCode, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDACC1.224
else FPRDACC1.225
! 3.5 else write warning message and reset icode FPRDACC1.226
write(UnWarn,*)CWarn//CSub// FPRDACC1.227
# 'NWP preferred field (VT-6) StCode ', FPRDACC1.228
# StCode, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDACC1.229
l_preferred_M6 = .false. FPRDACC1.230
end if FPRDACC1.231
icode = 0 ! reset icode FPRDACC1.232
endif ! l_preferred_VT FPRDACC1.233
endif ! l_preferred_VT / l_preferred_M6 FPRDACC1.234
FPRDACC1.235
! 3.6 If either preferred VT or preferred M6 has not been read FPRDACC1.236
! read previous VT and VT-6 FPRDACC1.237
if ( (.not. l_preferred_M6 .or. .not. l_preferred_VT) .and. FPRDACC1.238
# ( l_previous_M6 .and. l_previous_VT ) .and. FPRDACC1.239
# LPrevious ) then FPRDACC1.240
call add_hours( FPRDACC1.241
*CALL AREFTIM FPRDACC1.242
*CALL AVALTIM FPRDACC1.243
# IVTOffHr) FPRDACC1.244
call read_one_field (UnitPrevious, ITEM_CODE, StCode, FPRDACC1.245
*CALL AVALTIM FPRDACC1.246
# Len_FixHd, FixHdPrevious,Len1_Lookup, FPRDACC1.247
# Len2_ActualPrevious, LookupPrevious, LookFldNoPrevious, FPRDACC1.248
# ldebug, l_climate_field, FPRDACC1.249
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDACC1.250
# ncols, nrows, fieldVT, FPRDACC1.251
*CALL ARGPPX FPRDACC1.252
# icode) FPRDACC1.253
FPRDACC1.254
if ( icode .le. 0) then FPRDACC1.255
! 3.7 if successful, issue standard message and exit routine FPRDACC1.256
write(UnStd,*)CStd//CSub// FPRDACC1.257
# 'NWP previous field (VT) StCode ', FPRDACC1.258
# StCode, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDACC1.259
else FPRDACC1.260
! 3.8 else write warning message and reset icode FPRDACC1.261
write(UnWarn,*)CWarn//CSub// FPRDACC1.262
# 'NWP previous field (VT) StCode ', FPRDACC1.263
# StCode, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDACC1.264
l_previous_VT = .false. FPRDACC1.265
end if FPRDACC1.266
icode = 0 ! reset icode FPRDACC1.267
if ( l_previous_VT) then FPRDACC1.268
call add_hours( FPRDACC1.269
*CALL AREFTIM FPRDACC1.270
*CALL AVALTIM FPRDACC1.271
# IM6OffHr) FPRDACC1.272
call read_one_field (UnitPrevious, ITEM_CODE, StCode, FPRDACC1.273
*CALL AVALTIM FPRDACC1.274
# Len_FixHd, FixHdPrevious,Len1_Lookup, FPRDACC1.275
# Len2_ActualPrevious, LookupPrevious, LookFldNoPrevious, FPRDACC1.276
# ldebug, l_climate_field, FPRDACC1.277
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDACC1.278
# ncols, nrows, fieldM6, FPRDACC1.279
*CALL ARGPPX FPRDACC1.280
# icode) FPRDACC1.281
FPRDACC1.282
if ( icode .le. 0) then FPRDACC1.283
! 3.9 if successful, issue standard message and exit routine FPRDACC1.284
write(UnStd,*)CStd//CSub// FPRDACC1.285
# 'NWP previous field (VT-6) StCode ', FPRDACC1.286
# StCode, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDACC1.287
else FPRDACC1.288
! 3.10 else write warning message and reset icode FPRDACC1.289
write(UnWarn,*)CWarn//CSub// FPRDACC1.290
# 'NWP previous field (VT-6) StCode ', FPRDACC1.291
# StCode, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDACC1.292
l_previous_M6 = .false. FPRDACC1.293
end if FPRDACC1.294
icode = 0 ! reset icode FPRDACC1.295
endif ! l_previous_VT FPRDACC1.296
endif FPRDACC1.297
FPRDACC1.298
!---------------------------------------------------------------------- FPRDACC1.299
! 4. If there is a preferred field for VT-6 and for VT FPRDACC1.300
! or previous for VT-6 and VT then do accumulation FPRDACC1.301
!---------------------------------------------------------------------- FPRDACC1.302
if ( (l_preferred_VT .and. l_preferred_M6) .or. FPRDACC1.303
# (l_previous_VT .and. l_previous_M6) ) then FPRDACC1.304
call FieldSub (ncols,nrows,rmdi, FPRDACC1.305
# fieldVT,fieldM6, FPRDACC1.306
# fieldint, FPRDACC1.307
# icode,cmessage) FPRDACC1.308
FPRDACC1.309
! 4.1 Now divide the result by a scalar using ScalarMult FPRDACC1.310
timediv = 1.0 / time FPRDACC1.311
call ScalarMult (ncols,nrows,rmdi,timediv, FPRDACC1.312
# fieldint,field, FPRDACC1.313
# icode,cmessage) FPRDACC1.314
FPRDACC1.315
! 4.2 Write times to integer header FPRDACC1.316
call add_hours( FPRDACC1.317
*CALL AREFTIM FPRDACC1.318
*CALL AVALTIM FPRDACC1.319
# IVTOffHr) FPRDACC1.320
call amend_times ( FPRDACC1.321
*CALL AVALTIM FPRDACC1.322
# Int_Head,Len_IntHd ) FPRDACC1.323
goto 9999 FPRDACC1.324
endif ! test for both fields FPRDACC1.325
FPRDACC1.326
!---------------------------------------------------------------------- FPRDACC1.327
! 5. Otherwise extract field from climate file if available FPRDACC1.328
!---------------------------------------------------------------------- FPRDACC1.329
if (LClimate) then FPRDACC1.330
call read_climate_field(StCode, IVTOffHr, FPRDACC1.331
# ldebug, Int_Head, Real_Head, FPRDACC1.332
# ncols, nrows, field, FPRDACC1.333
*CALL ARGPPX FPRDACC1.334
# icode) FPRDACC1.335
FPRDACC1.336
if ( icode .le. 0) then FPRDACC1.337
write(UnStd,*)CStd//CSub//'5. climate field extracted ', FPRDACC1.338
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDACC1.339
go to 9999 FPRDACC1.340
else FPRDACC1.341
FPRDACC1.342
write(UnWarn,*)CWarn//CSub// FPRDACC1.343
# '5. failed to retrieve climate field ', FPRDACC1.344
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDACC1.345
icode = 0 FPRDACC1.346
end if ! icode FPRDACC1.347
end if ! LClimate FPRDACC1.348
FPRDACC1.349
!---------------------------------------------------------------------- FPRDACC1.350
! 6. If no data has been successfully extracted return an error code FPRDACC1.351
!---------------------------------------------------------------------- FPRDACC1.352
icode = 5 FPRDACC1.353
write(UnErr,*)CErr//CSub//'6. failed to extract any data', FPRDACC1.354
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDACC1.355
FPRDACC1.356
9999 continue FPRDACC1.357
return FPRDACC1.358
end FPRDACC1.359
!---------------------------------------------------------------------- FPRDACC1.360
*ENDIF FPRDACC1.361