subroutine read_one_field ( InUnit, item, itemvalue, 16,8FPRD1FLD.40
*CALL AVALTIM 
FPRD1FLD.41
# Len_FixHd, FixHd, Len1_Lookup, FPRD1FLD.42
# Len2_Lookup, Lookup, LookFldNo, FPRD1FLD.43
# ldebug, l_climate_field, FPRD1FLD.44
# Len_IntHd, Len_RealHd, IntHead, RealHead, FPRD1FLD.45
# ncols, nrows, field, FPRD1FLD.46
*CALL ARGPPX FPRD1FLD.47
# icode) FPRD1FLD.48
FPRD1FLD.49
implicit none FPRD1FLD.50
FPRD1FLD.51
! declaration of parameters FPRD1FLD.52
*CALL CLOOKADD FPRD1FLD.53
*CALL C_MDI FPRD1FLD.54
FPRD1FLD.55
! Local parameters: FPRD1FLD.56
integer len_full_word ! The length of a FULL_WORD FPRD1FLD.57
parameter ( len_full_word = 64 ) FPRD1FLD.58
FPRD1FLD.59
! declaration of argument list FPRD1FLD.60
FPRD1FLD.61
! search conditions (all intent IN) FPRD1FLD.62
integer InUnit ! IN unit number for input FPRD1FLD.63
integer item ! IN lookup header item to test FPRD1FLD.64
integer itemvalue ! IN value to look for FPRD1FLD.65
FPRD1FLD.66
! validity time to look for: intent IN FPRD1FLD.67
*CALL CVALTIM FPRD1FLD.68
FPRD1FLD.69
! fixed headers and lookup tables to use: all intent IN FPRD1FLD.70
integer Len_FixHd ! length of fixed header FPRD1FLD.71
integer FixHd(Len_FixHd) ! fixed header FPRD1FLD.72
integer Len1_Lookup, Len2_Lookup ! true lengths of tables FPRD1FLD.73
integer Lookup(Len1_Lookup, Len2_Lookup) ! lookup tables FPRD1FLD.74
integer LookFldNo(Len2_Lookup) ! field nos for lookups FPRD1FLD.75
FPRD1FLD.76
! control logical for debugging output FPRD1FLD.77
logical ldebug ! IN T => output debugging info FPRD1FLD.78
logical l_climate_field ! IN T => trying to read climate field FPRD1FLD.79
! F => trying to read NWP field FPRD1FLD.80
FPRD1FLD.81
! lengths of Lookup table FPRD1FLD.82
integer Len_IntHd ! IN length of integer part of lookup FPRD1FLD.83
integer Len_RealHd ! IN length of real part of lookup FPRD1FLD.84
FPRD1FLD.85
! lookup tables of field found FPRD1FLD.86
integer IntHead(Len_IntHd) ! OUT integer part FPRD1FLD.87
real RealHead(Len_RealHd) FPRD1FLD.88
! OUT real part FPRD1FLD.89
FPRD1FLD.90
! output field FPRD1FLD.91
integer ncols ! IN number of columns FPRD1FLD.92
integer nrows ! IN number of rows FPRD1FLD.93
real field(ncols,nrows) ! OUT field values FPRD1FLD.94
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPRD1FLD.95
FPRD1FLD.96
! declaration of globals used FPRD1FLD.97
*CALL CSUBMODL FPRD1FLD.98
*CALL CPPXREF FPRD1FLD.99
*CALL PPXLOOK FPRD1FLD.100
*CALL CUNITNOS FPRD1FLD.101
*CALL CMESS FPRD1FLD.102
*CALL CDEBUG FPRD1FLD.103
FPRD1FLD.104
! declaration of local arrays FPRD1FLD.105
integer field_wgdos_packed(ncols*nrows) ! wgdos packed field FPRD1FLD.106
FPRD1FLD.107
! declaration of local scalars FPRD1FLD.108
integer fld_no ! number of field matching search conditions FPRD1FLD.109
integer i ! do loop index FPRD1FLD.110
integer nvalues ! # values in wgdos packed field FPRD1FLD.111
integer idum ! dummy integer FPRD1FLD.112
integer ixx ! # of columns in grid according to coex FPRD1FLD.113
integer iyy ! # of rows in grid according to coex FPRD1FLD.114
logical ItemFound ! T => item to search for has been found FPRD1FLD.115
logical l_data_time ! T => use data time; F => use validity time FPRD1FLD.116
FPRD1FLD.117
real offset ! offset of data from zero FPRD1FLD.118
real scale ! MKS scaling factor FPRD1FLD.119
real rmdit ! rmdi read in from file FPRD1FLD.120
FPRD1FLD.121
character *256 cmessage ! error message FPRD1FLD.122
FPRD1FLD.123
external time_to_use, readflds, copy_to_real, scalarmult, FPRD1FLD.124
# scalaradd,output_debug FPRD1FLD.125
FPRD1FLD.126
!---------------------------------------------------------------------- FPRD1FLD.127
FPRD1FLD.128
!---------------------------------------------------------------------- FPRD1FLD.129
! 0. Preliminaries FPRD1FLD.130
CSub = 'read_one_field' ! subroutine name for error messages FPRD1FLD.131
idum = 0 ! dummy integer used in call coex FPRD1FLD.132
FPRD1FLD.133
! 1. Decide whether to search lookups using validity or data time FPRD1FLD.134
FPRD1FLD.135
call time_to_use ( itemvalue, l_climate_field, l_data_time) FPRD1FLD.136
FPRD1FLD.137
! 2. Search lookup tables for match on date and stash item FPRD1FLD.138
FPRD1FLD.139
! 2.1 search lookup tables using data time FPRD1FLD.140
FPRD1FLD.141
ItemFound = .false. FPRD1FLD.142
FPRD1FLD.143
if ( l_data_time ) then FPRD1FLD.144
FPRD1FLD.145
do i = 1, Len2_Lookup FPRD1FLD.146
if ( Lookup(LBYRD,i) .eq. ValidYear .and. FPRD1FLD.147
# Lookup(LBMOND,i) .eq. ValidMonth .and. FPRD1FLD.148
# Lookup(LBDATD,i) .eq. ValidDay .and. FPRD1FLD.149
# Lookup(LBHRD,i) .eq. ValidHour .and. FPRD1FLD.150
# Lookup(LBMIND,i) .eq. ValidMin .and. FPRD1FLD.151
# Lookup(item,i) .eq. itemvalue ) then FPRD1FLD.152
ItemFound = .true. FPRD1FLD.153
fld_no = LookFldNo(i) FPRD1FLD.154
go to 100 FPRD1FLD.155
end if FPRD1FLD.156
end do FPRD1FLD.157
FPRD1FLD.158
! 2.2 Search lookup tables using validity time FPRD1FLD.159
else ! .not. l_data_time FPRD1FLD.160
FPRD1FLD.161
do i = 1, Len2_Lookup FPRD1FLD.162
if ( Lookup(LBYR,i) .eq. ValidYear .and. FPRD1FLD.163
# Lookup(LBMON,i) .eq. ValidMonth .and. FPRD1FLD.164
# Lookup(LBDAT,i) .eq. ValidDay .and. FPRD1FLD.165
# Lookup(LBHR,i) .eq. ValidHour .and. FPRD1FLD.166
# Lookup(LBMIN,i) .eq. ValidMin .and. FPRD1FLD.167
# Lookup(item,i) .eq. itemvalue ) then FPRD1FLD.168
ItemFound = .true. FPRD1FLD.169
fld_no = LookFldNo(i) FPRD1FLD.170
go to 100 FPRD1FLD.171
end if FPRD1FLD.172
end do FPRD1FLD.173
FPRD1FLD.174
endif ! l_data_time FPRD1FLD.175
FPRD1FLD.176
100 continue FPRD1FLD.177
FPRD1FLD.178
! if item has not been found set icode > 0 and exit routine FPRD1FLD.179
FPRD1FLD.180
if ( .not. ItemFound ) then FPRD1FLD.181
icode = 36 FPRD1FLD.182
write(UnWarn,*)CWarn,CSub, FPRD1FLD.183
# ' step 2. unable to find required field ' FPRD1FLD.184
go to 9999 FPRD1FLD.185
end if FPRD1FLD.186
FPRD1FLD.187
FPRD1FLD.188
! 3. check that nrows and ncols agree with those in lookup table FPRD1FLD.189
FPRD1FLD.190
if ( Lookup(LBNPT,fld_no) .ne. ncols ) then FPRD1FLD.191
icode = 37 FPRD1FLD.192
write(UnWarn,*)CWarn,CSub,'3.1 number of columns do ', FPRD1FLD.193
# 'not agree: ' ,ncols, Lookup(LBNPT,fld_no) FPRD1FLD.194
go to 9999 FPRD1FLD.195
end if FPRD1FLD.196
FPRD1FLD.197
if ( Lookup(LBROW,fld_no) .ne. nrows ) then FPRD1FLD.198
icode = 38 FPRD1FLD.199
write(UnWarn,*)CWarn,CSub,'3.2 number of rows do ', FPRD1FLD.200
# 'not agree: ' ,nrows, Lookup(LBROW,fld_no) FPRD1FLD.201
go to 9999 FPRD1FLD.202
end if FPRD1FLD.203
FPRD1FLD.204
! 4. If found: Use READFIELDS to extract field FPRD1FLD.205
FPRD1FLD.206
! 4.1 extract field which is wgdos packed FPRD1FLD.207
FPRD1FLD.208
if ( MOD ( Lookup(LBPACK,fld_no) ,10) .eq. 1) then FPRD1FLD.209
FPRD1FLD.210
nvalues = Lookup(LBLREC,fld_no) FPRD1FLD.211
FPRD1FLD.212
call readflds (InUnit , 1, fld_no, LOOKUP, FPRD1FLD.213
# Len1_Lookup, field_wgdos_packed, nvalues, FIXHD, FPRD1FLD.214
*CALL ARGPPX FPRD1FLD.215
# icode, cmessage) FPRD1FLD.216
FPRD1FLD.217
if ( icode .gt. 0 ) then FPRD1FLD.218
write(UnWarn,*)CWarn,CSub, FPRD1FLD.219
# ' step 4.1 unable to read field: cmessage is ', FPRD1FLD.220
# cmessage FPRD1FLD.221
icode = 39 FPRD1FLD.222
go to 9999 FPRD1FLD.223
end if FPRD1FLD.224
FPRD1FLD.225
call coex(field, ! OUT unpacked field FPRD1FLD.226
& nrows*ncols, ! IN size of unpacked field FPRD1FLD.227
& field_wgdos_packed, ! IN packed field FPRD1FLD.228
& nvalues, ! IN size of packed field FPRD1FLD.229
& ixx,iyy, ! OUT row and column sizes FPRD1FLD.230
& idum,idum, ! IN not used FPRD1FLD.231
& .false., ! IN => expansion FPRD1FLD.232
& rmdi, ! IN real missing data value FPRD1FLD.233
& len_full_word) ! IN length of a full word FPRD1FLD.234
FPRD1FLD.235
if ( ixx .ne. ncols .or. iyy .ne. nrows ) then FPRD1FLD.236
icode = 40 FPRD1FLD.237
write(UnWarn,*)CWarn,CSub, FPRD1FLD.238
# ' step 4.1 number of rows and columns garbled ? ', FPRD1FLD.239
# ixx, ncols, iyy, nrows FPRD1FLD.240
go to 9999 FPRD1FLD.241
end if FPRD1FLD.242
FPRD1FLD.243
! 4.2 or extract field which is not packed FPRD1FLD.244
FPRD1FLD.245
else FPRD1FLD.246
FPRD1FLD.247
if ( Lookup(LBLREC,fld_no) .ne. ncols*nrows) then FPRD1FLD.248
icode = 41 FPRD1FLD.249
write(UnWarn,*)CWarn,CSub, FPRD1FLD.250
# ' step 4.2 wrong number of data points in field ', FPRD1FLD.251
# Lookup(LBLREC,fld_no), ncols*nrows, ncols, nrows FPRD1FLD.252
go to 9999 FPRD1FLD.253
end if FPRD1FLD.254
FPRD1FLD.255
call readflds (InUnit , 1, fld_no, LOOKUP, FPRD1FLD.256
# Len1_Lookup, Field, ncols*nrows, FIXHD, FPRD1FLD.257
*CALL ARGPPX FPRD1FLD.258
# icode, cmessage) FPRD1FLD.259
FPRD1FLD.260
if ( icode .gt. 0 ) then FPRD1FLD.261
write(UnWarn,*)CWarn,CSub, FPRD1FLD.262
# ' step 4.2 unable to read field: cmessage is ', FPRD1FLD.263
# cmessage FPRD1FLD.264
icode = 42 FPRD1FLD.265
go to 9999 FPRD1FLD.266
end if FPRD1FLD.267
FPRD1FLD.268
end if ! Lookup(LBPACK,fld_no) FPRD1FLD.269
FPRD1FLD.270
! 5. convert lookup table to Int_Head and Real_Head FPRD1FLD.271
! and field to a 2D field FPRD1FLD.272
FPRD1FLD.273
do i = 1, Len_IntHd FPRD1FLD.274
IntHead(i) = Lookup(i,fld_no) FPRD1FLD.275
end do FPRD1FLD.276
FPRD1FLD.277
do i = Len_IntHd+1, Len_IntHd+Len_RealHd FPRD1FLD.278
call copy_to_real( Lookup(i,fld_no), FPRD1FLD.279
# RealHead(i-Len_IntHd) ) FPRD1FLD.280
end do FPRD1FLD.281
FPRD1FLD.282
! 6. correct data offset and change to SI units FPRD1FLD.283
rmdit = RealHead(BMDI - Len_IntHd) FPRD1FLD.284
FPRD1FLD.285
if ( rmdit .ne. rmdi ) then FPRD1FLD.286
icode = 43 FPRD1FLD.287
write(UnWarn,*)CWarn,CSub, FPRD1FLD.288
# ' step 6.1 real missing data indicators do not match: ', FPRD1FLD.289
# rmdit, rmdi FPRD1FLD.290
go to 9999 FPRD1FLD.291
end if FPRD1FLD.292
FPRD1FLD.293
offset = RealHead(BDATUM - Len_IntHd) FPRD1FLD.294
if ( offset .ne. rmdi .and. offset .ne. 0.0 ) then FPRD1FLD.295
call ScalarAdd(ncols, nrows, rmdi, offset, FPRD1FLD.296
# Field, Field, icode, cmessage) FPRD1FLD.297
RealHead(BDATUM - Len_IntHd) = rmdi FPRD1FLD.298
FPRD1FLD.299
write(UnWarn,*)CWarn,CSub, FPRD1FLD.300
# ' step 6.2 adding offset factor ', offset FPRD1FLD.301
FPRD1FLD.302
end if FPRD1FLD.303
FPRD1FLD.304
scale = RealHead(BMKS - Len_IntHd) FPRD1FLD.305
if ( scale .ne. rmdi .and. scale .ne. 1.0 ) then FPRD1FLD.306
call ScalarMult(ncols, nrows, rmdi, scale, FPRD1FLD.307
# Field, Field, icode, cmessage) FPRD1FLD.308
RealHead(BMKS - Len_IntHd) = rmdi FPRD1FLD.309
FPRD1FLD.310
write(UnWarn,*)CWarn,CSub, FPRD1FLD.311
# ' step 6.3 multiplying by factor ', scale FPRD1FLD.312
FPRD1FLD.313
end if FPRD1FLD.314
FPRD1FLD.315
! 7. output debug info FPRD1FLD.316
if (ldebug) then FPRD1FLD.317
write(OutUnitDbg,*) ' read_data: unit ', InUnit,'; item ', FPRD1FLD.318
# '; itemvalue ', itemvalue FPRD1FLD.319
CMessage = ' ' FPRD1FLD.320
call output_debug(CMessage, nrows, ncols, Field) FPRD1FLD.321
end if FPRD1FLD.322
FPRD1FLD.323
9999 continue FPRD1FLD.324
return FPRD1FLD.325
end FPRD1FLD.326
!---------------------------------------------------------------------- FPRD1FLD.327
*ENDIF FPRD1FLD.328