subroutine read_vector_flds(StCode1,StCode2, 2,13FPRDVECF.39
# IVTOffHr, ldebug, FPRDVECF.40
# Int_Head1, Int_Head2, FPRDVECF.41
# Real_Head1, Real_Head2, FPRDVECF.42
# ncols, nrows, field1, field2, FPRDVECF.43
*CALL ARGPPX 
FPRDVECF.44
# icode) FPRDVECF.45
FPRDVECF.46
implicit none FPRDVECF.47
FPRDVECF.48
! declaration of parameters FPRDVECF.49
*CALL CSUBMODL FPRDVECF.50
*CALL CPPXREF FPRDVECF.51
*CALL PPXLOOK FPRDVECF.52
*CALL CLOOKADD FPRDVECF.53
*CALL PLOOKUPS FPRDVECF.54
FPRDVECF.55
FPRDVECF.56
! declaration of argument list FPRDVECF.57
FPRDVECF.58
FPRDVECF.59
! Stash codes needed for test FPRDVECF.60
integer StCode1 ! IN StCode1 value to test FPRDVECF.61
integer StCode2 ! IN StCode2 value to test FPRDVECF.62
FPRDVECF.63
FPRDVECF.64
! Reference date is used with IVTOffHr to define validity FPRDVECF.65
! time needed FPRDVECF.66
integer IVTOffHr ! IN offset from validity time in hours FPRDVECF.67
FPRDVECF.68
! declare logicals FPRDVECF.69
! debug control variable FPRDVECF.70
logical ldebug ! IN T => output debugging info FPRDVECF.71
logical l_climate_field ! set to false initially FPRDVECF.72
FPRDVECF.73
! lookup tables FPRDVECF.74
integer Int_Head1(Len_IntHd) ! OUT FPRDVECF.75
integer Int_Head2(Len_IntHd) ! OUT FPRDVECF.76
real Real_Head1(Len_RealHd) ! OUT FPRDVECF.77
real Real_Head2(Len_RealHd) ! OUT FPRDVECF.78
FPRDVECF.79
! output field FPRDVECF.80
integer ncols ! IN number of columns FPRDVECF.81
integer nrows ! IN number of rows FPRDVECF.82
real field1(ncols,nrows) ! OUT field values FPRDVECF.83
real field2(ncols,nrows) ! OUT field values FPRDVECF.84
FPRDVECF.85
! error code FPRDVECF.86
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPRDVECF.87
FPRDVECF.88
FPRDVECF.89
! declaration of globals used FPRDVECF.90
*CALL CUNITNOS FPRDVECF.91
*CALL CMESS FPRDVECF.92
FPRDVECF.93
*CALL CLOOKUPS FPRDVECF.94
FPRDVECF.95
*CALL CREFTIM FPRDVECF.96
*CALL CVALTIM FPRDVECF.97
FPRDVECF.98
! declaration of logicals FPRDVECF.99
logical l_present_field1 ! test for NWP field 1 FPRDVECF.100
logical l_present_field2 ! test for NWP field 2 FPRDVECF.101
FPRDVECF.102
! no local scalars FPRDVECF.103
FPRDVECF.104
! declaration of externals FPRDVECF.105
external add_hours, read_one_field, read_climate_field, FPRDVECF.106
# check_header FPRDVECF.107
!---------------------------------------------------------------------- FPRDVECF.108
! 0. Preliminaries FPRDVECF.109
CSub = 'read_vector_flds' ! subroutine name for error messages FPRDVECF.110
l_present_field1 = .false. FPRDVECF.111
l_present_field2 = .false. FPRDVECF.112
l_climate_field = .false. FPRDVECF.113
FPRDVECF.114
! 1. calculate validity time of NWP data required FPRDVECF.115
FPRDVECF.116
call add_hours( FPRDVECF.117
*CALL AREFTIM FPRDVECF.118
*CALL AVALTIM FPRDVECF.119
# IVTOffHr) FPRDVECF.120
FPRDVECF.121
!---------------------------------------------------------------------- FPRDVECF.122
! 2. Extract NWP field 1 and NWP field 2 if both available as preferred FPRDVECF.123
!---------------------------------------------------------------------- FPRDVECF.124
FPRDVECF.125
if ( LPreferred ) then FPRDVECF.126
call check_header (StCode1,Len1_Lookup, FPRDVECF.127
# Len2_ActualPreferred, FPRDVECF.128
# LookupPreferred, FPRDVECF.129
*CALL AVALTIM FPRDVECF.130
# l_present_field1) FPRDVECF.131
! FPRDVECF.132
call check_header (StCode2,Len1_Lookup, FPRDVECF.133
# Len2_ActualPreferred, FPRDVECF.134
# LookupPreferred, FPRDVECF.135
*CALL AVALTIM FPRDVECF.136
# l_present_field2) FPRDVECF.137
endif ! LPreferred FPRDVECF.138
FPRDVECF.139
! 2.1 If both fields exist, read them both FPRDVECF.140
if ( l_present_field1 .and. l_present_field2 ) then FPRDVECF.141
call read_one_field (UnitPreferred,ITEM_CODE,StCode1, FPRDVECF.142
*CALL AVALTIM FPRDVECF.143
# Len_FixHd, FixHdPreferred,Len1_Lookup, FPRDVECF.144
# Len2_ActualPreferred, LookupPreferred, LookFldNoPreferred, FPRDVECF.145
# ldebug, l_climate_field, FPRDVECF.146
# Len_IntHd, Len_RealHd, Int_Head1, Real_Head1, FPRDVECF.147
# ncols, nrows, field1, FPRDVECF.148
*CALL ARGPPX FPRDVECF.149
# icode) FPRDVECF.150
FPRDVECF.151
if ( icode .le. 0) then FPRDVECF.152
FPRDVECF.153
! 2.1.2 if NWP read successful, issue standard message FPRDVECF.154
write(UnStd,*)CStd//CSub//'NWP preferred field 1 StCode ', FPRDVECF.155
# StCode1, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDVECF.156
else FPRDVECF.157
! 2.1.3 else write warning message and set l_present_preferred to false FPRDVECF.158
write(UnWarn,*)CWarn//CSub// FPRDVECF.159
# 'NWP preferred field 1 StCode ', FPRDVECF.160
# StCode1, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDVECF.161
l_present_field1 = .false. FPRDVECF.162
icode = 0 ! reset icode FPRDVECF.163
endif FPRDVECF.164
FPRDVECF.165
! 2.1.4 read NWP field 2 FPRDVECF.166
call read_one_field (UnitPreferred,ITEM_CODE,StCode2, FPRDVECF.167
*CALL AVALTIM FPRDVECF.168
# Len_FixHd, FixHdPreferred,Len1_Lookup, FPRDVECF.169
# Len2_ActualPreferred, LookupPreferred, LookFldNoPreferred, FPRDVECF.170
# ldebug, l_climate_field, FPRDVECF.171
# Len_IntHd, Len_RealHd, Int_Head2, Real_Head2, FPRDVECF.172
# ncols, nrows, field2, FPRDVECF.173
*CALL ARGPPX FPRDVECF.174
# icode) FPRDVECF.175
FPRDVECF.176
if ( icode .le. 0) then FPRDVECF.177
FPRDVECF.178
! 2.1.5 if successful, issue standard message FPRDVECF.179
write(UnStd,*)CStd//CSub// FPRDVECF.180
# 'NWP preferred field 2 StCode ', FPRDVECF.181
# StCode2, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDVECF.182
else FPRDVECF.183
! 2.1.6 else write warning message and set l_present_preferred to false FPRDVECF.184
write(UnWarn,*)CWarn//CSub// FPRDVECF.185
# 'NWP preferred field 2 StCode ', FPRDVECF.186
# StCode2, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDVECF.187
l_present_field2 = .false. FPRDVECF.188
icode = 0 ! reset icode FPRDVECF.189
endif FPRDVECF.190
endif ! l_present_field1 / l_present_field2 FPRDVECF.191
FPRDVECF.192
!---------------------------------------------------------------------- FPRDVECF.193
! 3. If either read fails extract previous fields if available FPRDVECF.194
!---------------------------------------------------------------------- FPRDVECF.195
if ( LPrevious ) then FPRDVECF.196
if ( .not. l_present_field1 .or. FPRDVECF.197
# .not. l_present_field2 ) then FPRDVECF.198
call check_header (StCode1,Len1_Lookup, FPRDVECF.199
# Len2_ActualPrevious, FPRDVECF.200
# LookupPrevious, FPRDVECF.201
*CALL AVALTIM FPRDVECF.202
# l_present_field1) FPRDVECF.203
! FPRDVECF.204
call check_header (StCode2,Len1_Lookup, FPRDVECF.205
# Len2_ActualPrevious, FPRDVECF.206
# LookupPrevious, FPRDVECF.207
*CALL AVALTIM FPRDVECF.208
# l_present_field2) FPRDVECF.209
FPRDVECF.210
! 3.1 If both are present, read previous fields FPRDVECF.211
if ( l_present_field1 .and. l_present_field2 ) then FPRDVECF.212
call read_one_field (UnitPrevious, ITEM_CODE, StCode1, FPRDVECF.213
*CALL AVALTIM FPRDVECF.214
# Len_FixHd, FixHdPrevious,Len1_Lookup, FPRDVECF.215
# Len2_ActualPrevious, LookupPrevious, LookFldNoPrevious, FPRDVECF.216
# ldebug, l_climate_field, FPRDVECF.217
# Len_IntHd, Len_RealHd, Int_Head1, Real_Head1, FPRDVECF.218
# ncols, nrows, field1, FPRDVECF.219
*CALL ARGPPX FPRDVECF.220
# icode) FPRDVECF.221
FPRDVECF.222
if ( icode .le. 0) then FPRDVECF.223
FPRDVECF.224
! 3.1.1 if successful, issue standard message. FPRDVECF.225
FPRDVECF.226
write(UnStd,*)CStd//CSub// FPRDVECF.227
# 'NWP previous field1 StCode ', FPRDVECF.228
# StCode1, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDVECF.229
FPRDVECF.230
else FPRDVECF.231
FPRDVECF.232
! 3.1.2 else write warning message and reset icode FPRDVECF.233
write(UnWarn,*)CWarn//CSub// FPRDVECF.234
# 'NWP previous field1 StCode ', FPRDVECF.235
# StCode1, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDVECF.236
l_present_field1 = .false. FPRDVECF.237
end if ! icode FPRDVECF.238
icode = 0 ! reset icode FPRDVECF.239
FPRDVECF.240
! 3.2 Read previous field 2 FPRDVECF.241
call read_one_field (UnitPrevious, ITEM_CODE, StCode2, FPRDVECF.242
*CALL AVALTIM FPRDVECF.243
# Len_FixHd, FixHdPrevious,Len1_Lookup, FPRDVECF.244
# Len2_ActualPrevious, LookupPrevious, LookFldNoPrevious, FPRDVECF.245
# ldebug, l_climate_field, FPRDVECF.246
# Len_IntHd, Len_RealHd, Int_Head2, Real_Head2, FPRDVECF.247
# ncols, nrows, field2, FPRDVECF.248
*CALL ARGPPX FPRDVECF.249
# icode) FPRDVECF.250
FPRDVECF.251
if ( icode .le. 0) then FPRDVECF.252
FPRDVECF.253
! 3.2.1 if successful, issue standard message. FPRDVECF.254
FPRDVECF.255
write(UnStd,*)CStd//CSub// FPRDVECF.256
# 'field2 previous field stcode ', FPRDVECF.257
# StCode2, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDVECF.258
FPRDVECF.259
else FPRDVECF.260
FPRDVECF.261
! 3.2.2 else write warning message and reset icode FPRDVECF.262
write(UnWarn,*)CWarn//CSub// FPRDVECF.263
# 'NWP previous field2 stcode ', FPRDVECF.264
# StCode2, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDVECF.265
l_present_field2 = .false. FPRDVECF.266
end if ! icode FPRDVECF.267
icode = 0 ! reset icode FPRDVECF.268
FPRDVECF.269
endif ! l_present_field1 / l_present_field2 FPRDVECF.270
endif ! .not. l_present_field2 .or. l_present_field1 FPRDVECF.271
endif ! LPrevious FPRDVECF.272
FPRDVECF.273
!---------------------------------------------------------------------- FPRDVECF.274
! 4. If both fields exist, exit routine FPRDVECF.275
!---------------------------------------------------------------------- FPRDVECF.276
if ( l_present_field1 .and. l_present_field2) then FPRDVECF.277
! 4.1 Write times to integer headers FPRDVECF.278
call amend_times ( FPRDVECF.279
*CALL AVALTIM FPRDVECF.280
# Int_Head1,Len_IntHd ) FPRDVECF.281
call amend_times ( FPRDVECF.282
*CALL AVALTIM FPRDVECF.283
# Int_Head2,Len_IntHd ) FPRDVECF.284
goto 9999 FPRDVECF.285
endif ! l_present_field1 / l_present_field2 FPRDVECF.286
FPRDVECF.287
!---------------------------------------------------------------------- FPRDVECF.288
! 5. Otherwise extract fields from climate file if available FPRDVECF.289
!---------------------------------------------------------------------- FPRDVECF.290
if (LClimate) then FPRDVECF.291
FPRDVECF.292
! 5.1 read_climate field1 by calling read_climate field FPRDVECF.293
call read_climate_field(StCode1, IVTOffHr, FPRDVECF.294
# ldebug, Int_Head1, Real_Head1, FPRDVECF.295
# ncols, nrows, field1, FPRDVECF.296
*CALL ARGPPX FPRDVECF.297
# icode) FPRDVECF.298
FPRDVECF.299
if ( icode .le. 0) then FPRDVECF.300
write(UnStd,*)CStd//CSub//'5. climate field 1 extracted ', FPRDVECF.301
# ' for stash code =', stcode1, '; IVTOffHr = ', IVTOffHr FPRDVECF.302
else FPRDVECF.303
FPRDVECF.304
write(UnWarn,*)CWarn//CSub// FPRDVECF.305
# '5. failed to retrieve climate field 1 ', FPRDVECF.306
# ' for stash code =', stcode1, '; IVTOffHr = ', IVTOffHr FPRDVECF.307
icode = 5 FPRDVECF.308
write(UnErr,*)CErr//CSub//'Failed to extract any data', FPRDVECF.309
# ' for stash code =', stcode1, '; IVTOffHr = ', IVTOffHr FPRDVECF.310
goto 9999 FPRDVECF.311
end if FPRDVECF.312
FPRDVECF.313
! 5.2 read_climate field2 by calling read_climate field FPRDVECF.314
call read_climate_field(StCode2, IVTOffHr, FPRDVECF.315
# ldebug, Int_Head2, Real_Head2, FPRDVECF.316
# ncols, nrows, field2, FPRDVECF.317
*CALL ARGPPX FPRDVECF.318
# icode) FPRDVECF.319
FPRDVECF.320
if ( icode .le. 0) then FPRDVECF.321
write(UnStd,*)CStd//CSub//'5. climate field 2 extracted ', FPRDVECF.322
# ' for stash code =', stcode2, '; IVTOffHr = ', IVTOffHr FPRDVECF.323
go to 9999 FPRDVECF.324
else FPRDVECF.325
FPRDVECF.326
write(UnWarn,*)CWarn//CSub// FPRDVECF.327
# '5. failed to retrieve climate field 2 ', FPRDVECF.328
# ' for stash code =', stcode2, '; IVTOffHr = ', IVTOffHr FPRDVECF.329
icode = 5 FPRDVECF.330
write(UnErr,*)CErr//CSub//'Failed to extract any data', FPRDVECF.331
# ' for stash code =', stcode2, '; IVTOffHr = ', IVTOffHr FPRDVECF.332
end if FPRDVECF.333
FPRDVECF.334
end if ! LClimate FPRDVECF.335
FPRDVECF.336
9999 continue FPRDVECF.337
return FPRDVECF.338
end FPRDVECF.339
!---------------------------------------------------------------------- FPRDVECF.340
*ENDIF FPRDVECF.341