subroutine read_leads_flds(StCode,StCAICE, 10,14FPRDLEAD.47
# IVTOffHr, ldebug, l_leads,Int_Head, FPRDLEAD.48
# Real_Head, ncols, nrows, field, FPRDLEAD.49
*CALL ARGPPX 
FPRDLEAD.50
# icode) FPRDLEAD.51
FPRDLEAD.52
implicit none FPRDLEAD.53
FPRDLEAD.54
! declaration of parameters FPRDLEAD.55
*CALL CSUBMODL FPRDLEAD.56
*CALL CPPXREF FPRDLEAD.57
*CALL PPXLOOK FPRDLEAD.58
*CALL CLOOKADD FPRDLEAD.59
*CALL PLOOKUPS FPRDLEAD.60
FPRDLEAD.61
FPRDLEAD.62
! declaration of argument list FPRDLEAD.63
FPRDLEAD.64
! search criteria FPRDLEAD.65
FPRDLEAD.66
! Uses StCode to read NWP files FPRDLEAD.67
! stcode to read climate fields FPRDLEAD.68
FPRDLEAD.69
integer StCode ! IN stash code value to test FPRDLEAD.70
integer StCAICE ! IN icefrac code to test FPRDLEAD.71
FPRDLEAD.72
! Reference date is used with IVTOffHr to define validity FPRDLEAD.73
! time needed FPRDLEAD.74
integer IVTOffHr ! IN offset from validity time in hours FPRDLEAD.75
FPRDLEAD.76
! declare logicals FPRDLEAD.77
! debug control variable FPRDLEAD.78
logical ldebug ! IN T => output debugging info FPRDLEAD.79
logical l_leads ! if T => then using minleadsfrac FPRDLEAD.80
! if F => then using minicefrac FPRDLEAD.81
FPRDLEAD.82
! lookup tables FPRDLEAD.83
integer Int_Head(Len_IntHd) ! OUT FPRDLEAD.84
real Real_Head(Len_RealHd) ! OUT FPRDLEAD.85
FPRDLEAD.86
! output field FPRDLEAD.87
integer ncols ! IN number of columns FPRDLEAD.88
integer nrows ! IN number of rows FPRDLEAD.89
real field(ncols,nrows) ! OUT field values FPRDLEAD.90
FPRDLEAD.91
! error code FPRDLEAD.92
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPRDLEAD.93
FPRDLEAD.94
FPRDLEAD.95
! declaration of globals used FPRDLEAD.96
*CALL CUNITNOS FPRDLEAD.97
*CALL CMESS FPRDLEAD.98
*CALL C_MDI FPRDLEAD.99
*CALL CLOOKUPS FPRDLEAD.100
FPRDLEAD.101
*CALL CREFTIM FPRDLEAD.102
*CALL CVALTIM FPRDLEAD.103
FPRDLEAD.104
! declaration of logicals FPRDLEAD.105
logical l_present_fieldNWP ! test for NWP field FPRDLEAD.106
logical l_present_icefrac ! test for Icefrac field FPRDLEAD.107
logical l_climate_field ! set to false initially FPRDLEAD.108
FPRDLEAD.109
! declaration of local arrays FPRDLEAD.110
real fieldNWP (ncols,nrows) ! nwp field FPRDLEAD.111
real fieldClim (ncols,nrows) ! Climate field FPRDLEAD.112
real icefrac (ncols,nrows) ! icefrac field FPRDLEAD.113
real time ! division factor for sublimation FPRDLEAD.114
parameter (time = 1200) FPRDLEAD.115
real timediv ! 1 / time FPRDLEAD.116
FPRDLEAD.117
! no local scalars FPRDLEAD.118
integer i ! loop index for columns FPRDLEAD.119
integer j ! loop index for rows FPRDLEAD.120
character * 20 cmessage ! error message for scalarmult FPRDLEAD.121
FPRDLEAD.122
! declaration of externals FPRDLEAD.123
external add_hours, read_one_field, read_climate_field, FPRDLEAD.124
# check_header,interleave FPRDLEAD.125
FPRDLEAD.126
!---------------------------------------------------------------------- FPRDLEAD.127
! 0. Preliminaries FPRDLEAD.128
CSub = 'read_leads_flds' ! subroutine name for error messages FPRDLEAD.129
l_climate_field = .false. FPRDLEAD.130
FPRDLEAD.131
! 1. calculate validity time of NWP data required FPRDLEAD.132
FPRDLEAD.133
call add_hours( FPRDLEAD.134
*CALL AREFTIM FPRDLEAD.135
*CALL AVALTIM FPRDLEAD.136
# IVTOffHr) FPRDLEAD.137
FPRDLEAD.138
!---------------------------------------------------------------------- FPRDLEAD.139
! 2. Extract NWP field and icefrac field if available as preferred FPRDLEAD.140
!---------------------------------------------------------------------- FPRDLEAD.141
FPRDLEAD.142
if ( LPreferred ) then FPRDLEAD.143
call check_header (StCode,Len1_Lookup, FPRDLEAD.144
# Len2_ActualPreferred, FPRDLEAD.145
# LookupPreferred, FPRDLEAD.146
*CALL AVALTIM FPRDLEAD.147
# l_present_fieldNWP) FPRDLEAD.148
! FPRDLEAD.149
call check_header (StCAICE,Len1_Lookup, FPRDLEAD.150
# Len2_ActualPreferred, FPRDLEAD.151
# LookupPreferred, FPRDLEAD.152
*CALL AVALTIM FPRDLEAD.153
# l_present_icefrac) FPRDLEAD.154
endif ! LPreferred FPRDLEAD.155
FPRDLEAD.156
! 2.1 If both fields exist, read them both FPRDLEAD.157
if ( l_present_fieldNWP .and. l_present_icefrac ) then FPRDLEAD.158
call read_one_field (UnitPreferred,ITEM_CODE,StCode, FPRDLEAD.159
*CALL AVALTIM FPRDLEAD.160
# Len_FixHd, FixHdPreferred,Len1_Lookup, FPRDLEAD.161
# Len2_ActualPreferred, LookupPreferred, LookFldNoPreferred, FPRDLEAD.162
# ldebug, l_climate_field, FPRDLEAD.163
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDLEAD.164
# ncols, nrows, fieldNWP, FPRDLEAD.165
*CALL ARGPPX FPRDLEAD.166
# icode) FPRDLEAD.167
FPRDLEAD.168
if ( icode .le. 0) then FPRDLEAD.169
FPRDLEAD.170
! 2.1.2 if NWP read successful, issue standard message FPRDLEAD.171
write(UnStd,*)CStd//CSub//'NWP preferred field StCode ', FPRDLEAD.172
# StCode, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDLEAD.173
else FPRDLEAD.174
! 2.1.3 else write warning message and set l_present_preferred to false FPRDLEAD.175
write(UnWarn,*)CWarn//CSub//'NWP preferred field StCode ', FPRDLEAD.176
# StCAICE, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDLEAD.177
l_present_fieldNWP = .false. FPRDLEAD.178
icode = 0 ! reset icode FPRDLEAD.179
endif FPRDLEAD.180
FPRDLEAD.181
! 2.1.4 read icefrac field FPRDLEAD.182
call read_one_field (UnitPreferred,ITEM_CODE,StCAICE, FPRDLEAD.183
*CALL AVALTIM FPRDLEAD.184
# Len_FixHd, FixHdPreferred,Len1_Lookup, FPRDLEAD.185
# Len2_ActualPreferred, LookupPreferred, LookFldNoPreferred, FPRDLEAD.186
# ldebug, l_climate_field, FPRDLEAD.187
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDLEAD.188
# ncols, nrows, icefrac, FPRDLEAD.189
*CALL ARGPPX FPRDLEAD.190
# icode) FPRDLEAD.191
FPRDLEAD.192
if ( icode .le. 0) then FPRDLEAD.193
FPRDLEAD.194
! 2.1.5 if successful, issue standard message FPRDLEAD.195
write(UnStd,*)CStd//CSub//'icefrac preferred field StCode ', FPRDLEAD.196
# StCAICE, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDLEAD.197
else FPRDLEAD.198
! 2.1.6 else write warning message and set l_present_icefrac to false FPRDLEAD.199
write(UnWarn,*)CWarn//CSub// FPRDLEAD.200
# 'icefrac preferred field StCode ', FPRDLEAD.201
# StCAICE, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDLEAD.202
l_present_icefrac = .false. FPRDLEAD.203
icode = 0 ! reset icode FPRDLEAD.204
endif FPRDLEAD.205
endif ! l_present_fieldNWP / l_present_icefrac FPRDLEAD.206
FPRDLEAD.207
!---------------------------------------------------------------------- FPRDLEAD.208
! 3. If either read fails extract previous fields if available FPRDLEAD.209
!---------------------------------------------------------------------- FPRDLEAD.210
if ( .not. l_present_fieldNWP .or. FPRDLEAD.211
# .not. l_present_icefrac ) then FPRDLEAD.212
if ( LPrevious ) then FPRDLEAD.213
call check_header (StCode,Len1_Lookup, FPRDLEAD.214
# Len2_ActualPrevious, FPRDLEAD.215
# LookupPrevious, FPRDLEAD.216
*CALL AVALTIM FPRDLEAD.217
# l_present_fieldNWP) FPRDLEAD.218
! FPRDLEAD.219
call check_header (StCAICE,Len1_Lookup, FPRDLEAD.220
# Len2_ActualPrevious, FPRDLEAD.221
# LookupPrevious, FPRDLEAD.222
*CALL AVALTIM FPRDLEAD.223
# l_present_icefrac) FPRDLEAD.224
FPRDLEAD.225
! 3.1 If both are present, read previous fields FPRDLEAD.226
if ( l_present_fieldNWP .and. l_present_icefrac ) then FPRDLEAD.227
call read_one_field (UnitPrevious, FPRDLEAD.228
# ITEM_CODE,StCode, FPRDLEAD.229
*CALL AVALTIM FPRDLEAD.230
# Len_FixHd, FixHdPrevious,Len1_Lookup, FPRDLEAD.231
# Len2_ActualPrevious, LookupPrevious, LookFldNoPrevious, FPRDLEAD.232
# ldebug, l_climate_field, FPRDLEAD.233
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDLEAD.234
# ncols, nrows, fieldNWP, FPRDLEAD.235
*CALL ARGPPX FPRDLEAD.236
# icode) FPRDLEAD.237
FPRDLEAD.238
if ( icode .le. 0) then FPRDLEAD.239
FPRDLEAD.240
! 3.1.1 if successful, issue standard message. FPRDLEAD.241
FPRDLEAD.242
write(UnStd,*)CStd//CSub// FPRDLEAD.243
# 'NWP previous field StCode ', FPRDLEAD.244
# StCode, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDLEAD.245
FPRDLEAD.246
else FPRDLEAD.247
FPRDLEAD.248
! 3.1.2 else write warning message and reset icode FPRDLEAD.249
write(UnWarn,*)CWarn//CSub// FPRDLEAD.250
# 'NWP previous field StCode ', FPRDLEAD.251
# StCode, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDLEAD.252
l_present_fieldNWP = .false. FPRDLEAD.253
end if ! icode FPRDLEAD.254
icode = 0 ! reset icode FPRDLEAD.255
FPRDLEAD.256
! 3.2 Read previous icefrac field FPRDLEAD.257
call read_one_field (UnitPrevious, FPRDLEAD.258
# ITEM_CODE,StCAICE, FPRDLEAD.259
*CALL AVALTIM FPRDLEAD.260
# Len_FixHd, FixHdPrevious,Len1_Lookup, FPRDLEAD.261
# Len2_ActualPrevious, LookupPrevious, LookFldNoPrevious, FPRDLEAD.262
# ldebug, l_climate_field, FPRDLEAD.263
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDLEAD.264
# ncols, nrows, icefrac, FPRDLEAD.265
*CALL ARGPPX FPRDLEAD.266
# icode) FPRDLEAD.267
FPRDLEAD.268
if ( icode .le. 0) then FPRDLEAD.269
FPRDLEAD.270
! 3.2.1 if successful, issue standard message. FPRDLEAD.271
FPRDLEAD.272
write(UnStd,*)CStd//CSub// FPRDLEAD.273
# 'icefrac previous field StCode ', FPRDLEAD.274
# StCAICE, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDLEAD.275
FPRDLEAD.276
else FPRDLEAD.277
FPRDLEAD.278
! 3.2.2 else write warning message and reset icode FPRDLEAD.279
write(UnWarn,*)CWarn//CSub// FPRDLEAD.280
# 'icefrac previous field StCode ', FPRDLEAD.281
# StCAICE, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDLEAD.282
l_present_icefrac = .false. FPRDLEAD.283
end if ! icode FPRDLEAD.284
icode = 0 ! reset icode FPRDLEAD.285
FPRDLEAD.286
endif ! l_present_fieldNWP / l_present_icefrac FPRDLEAD.287
endif ! LPrevious FPRDLEAD.288
endif ! .not. l_present_fieldNWP .or. l_present_icefrac FPRDLEAD.289
FPRDLEAD.290
!---------------------------------------------------------------------- FPRDLEAD.291
! 4. If both fields exist, perform calculation FPRDLEAD.292
!---------------------------------------------------------------------- FPRDLEAD.293
if ( l_present_fieldNWP .and. l_present_icefrac) then FPRDLEAD.294
FPRDLEAD.295
! 4.1.1 Convert units in fieldNWP if StCode is 3231 FPRDLEAD.296
if ( StCode .eq. 3231 ) then FPRDLEAD.297
timediv = 1.0 / time FPRDLEAD.298
call ScalarMult (ncols, nrows, rmdi, FPRDLEAD.299
# timediv, fieldNWP, FPRDLEAD.300
# fieldNWP, FPRDLEAD.301
# icode, cmessage) FPRDLEAD.302
endif FPRDLEAD.303
FPRDLEAD.304
if (LClimate) then FPRDLEAD.305
FPRDLEAD.306
! 4.1.2 Read climate field into fieldClim FPRDLEAD.307
call read_climate_field(StCode, IVTOffHr, FPRDLEAD.308
# ldebug, Int_Head, Real_Head, FPRDLEAD.309
# ncols, nrows, fieldClim, FPRDLEAD.310
*CALL ARGPPX FPRDLEAD.311
# icode) FPRDLEAD.312
FPRDLEAD.313
! 4.1.2 If successful write out standard message FPRDLEAD.314
if ( icode .le. 0) then FPRDLEAD.315
write(UnStd,*)CStd//CSub//'Climate field extracted', FPRDLEAD.316
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDLEAD.317
else FPRDLEAD.318
! 4.1.2 If fails write out warning message FPRDLEAD.319
write(UnErr,*)CErr//CSub// FPRDLEAD.320
# '4. failed to retrieve climate field ', FPRDLEAD.321
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDLEAD.322
go to 9999 FPRDLEAD.323
end if FPRDLEAD.324
FPRDLEAD.325
! 4.2 Perform calculation using interleave FPRDLEAD.326
call interleave (ncols, nrows, FPRDLEAD.327
# fieldNWP, fieldClim, FPRDLEAD.328
# icefrac, rmdi, FPRDLEAD.329
# l_leads,field) FPRDLEAD.330
FPRDLEAD.331
else ! LClimate FPRDLEAD.332
FPRDLEAD.333
do i = 1, ncols FPRDLEAD.334
do j = 1, nrows FPRDLEAD.335
field(i,j) = fieldNWP(i,j) FPRDLEAD.336
enddo FPRDLEAD.337
enddo FPRDLEAD.338
FPRDLEAD.339
endif ! LClimate FPRDLEAD.340
FPRDLEAD.341
! 4.3. Write times to integer header FPRDLEAD.342
call amend_times ( FPRDLEAD.343
*CALL AVALTIM FPRDLEAD.344
# Int_Head,Len_IntHd ) FPRDLEAD.345
go to 9999 FPRDLEAD.346
endif ! l_present_fieldNWP / l_present_icefrac FPRDLEAD.347
FPRDLEAD.348
!---------------------------------------------------------------------- FPRDLEAD.349
! 5. Otherwise extract field from climate file if available FPRDLEAD.350
!---------------------------------------------------------------------- FPRDLEAD.351
if (LClimate) then FPRDLEAD.352
FPRDLEAD.353
! 5.1 read_climate field by calling read_climate field FPRDLEAD.354
call read_climate_field(StCode, IVTOffHr, FPRDLEAD.355
# ldebug, Int_Head, Real_Head, FPRDLEAD.356
# ncols, nrows, field, FPRDLEAD.357
*CALL ARGPPX FPRDLEAD.358
# icode) FPRDLEAD.359
FPRDLEAD.360
if ( icode .le. 0) then FPRDLEAD.361
write(UnStd,*)CStd//CSub//'4. climate field extracted ', FPRDLEAD.362
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDLEAD.363
go to 9999 FPRDLEAD.364
else FPRDLEAD.365
FPRDLEAD.366
write(UnErr,*)CErr//CSub// FPRDLEAD.367
# '4. failed to retrieve climate field ', FPRDLEAD.368
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDLEAD.369
go to 9999 FPRDLEAD.370
end if FPRDLEAD.371
FPRDLEAD.372
end if ! LClimate/l_present_output FPRDLEAD.373
FPRDLEAD.374
!---------------------------------------------------------------------- FPRDLEAD.375
! 6. If no data has been successfully extracted return an error code FPRDLEAD.376
!---------------------------------------------------------------------- FPRDLEAD.377
icode = 5 FPRDLEAD.378
write(UnErr,*)CErr//CSub//'5. failed to extract any data', FPRDLEAD.379
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDLEAD.380
FPRDLEAD.381
9999 continue FPRDLEAD.382
return FPRDLEAD.383
end FPRDLEAD.384
!---------------------------------------------------------------------- FPRDLEAD.385
*ENDIF FPRDLEAD.386