subroutine write_one_field ( 18,11FPWR1FLD.40
*CALL AFIELDS 
FPWR1FLD.41
# StCode, FFCode, PPCode, IVTOffHr, FPWR1FLD.42
# Int_Head, Real_Head, IOutUnit, ldebug, IGridtype, nrows, FPWR1FLD.43
# field_atm, icode ) FPWR1FLD.44
FPWR1FLD.45
implicit none FPWR1FLD.46
FPWR1FLD.47
! declaration of parameters used in argument list FPWR1FLD.48
*CALL PLOOKUPS FPWR1FLD.49
FPWR1FLD.50
! declaration of argument list FPWR1FLD.51
FPWR1FLD.52
! array dimensions, lsms, interpolation coeffs etc. : all intent IN FPWR1FLD.53
*CALL CFIELDS FPWR1FLD.54
FPWR1FLD.55
! field codes to insert in integer header that is output FPWR1FLD.56
integer StCode ! IN stash code FPWR1FLD.57
integer FFCode ! IN Met O 8 field code FPWR1FLD.58
integer PPCode ! IN PP package code FPWR1FLD.59
integer IVTOffHr ! IN offset of validity time from reference FPWR1FLD.60
integer Int_Head(Len_IntHd) ! IN integer part of lookup table FPWR1FLD.61
real Real_Head(Len_RealHd) ! IN real part of lookup table FPWR1FLD.62
FPWR1FLD.63
integer IOutUnit ! IN output unit FPWR1FLD.64
logical ldebug ! IN T => output debugging info FPWR1FLD.65
FPWR1FLD.66
integer IGridtype ! IN grid type (0 = tracer, 1 = velocity) FPWR1FLD.67
integer nrows ! IN number of rows in input field FPWR1FLD.68
FPWR1FLD.69
real field_atm( ncols, nrows ) ! IN field on NWP grid FPWR1FLD.70
FPWR1FLD.71
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPWR1FLD.72
FPWR1FLD.73
FPWR1FLD.74
! declaration of parameters FPWR1FLD.75
*CALL C_MDI FPWR1FLD.76
FPWR1FLD.77
! declaration of globals used FPWR1FLD.78
*CALL CUNITNOS FPWR1FLD.79
*CALL CMESS FPWR1FLD.80
*CALL CLOOKUPS FPWR1FLD.81
*CALL CVALOFF FPWR1FLD.82
FPWR1FLD.83
! declaration of local arrays FPWR1FLD.84
real field_ocean( ncolsO, nrowstO ) ! used for both t and u cases FPWR1FLD.85
integer index_unres ( ncolsO * nrowstO ) ! indices to unresolved FPWR1FLD.86
! points on ocean grid FPWR1FLD.87
!---------------------------------------------------------------------- FPWR1FLD.88
FPWR1FLD.89
! declaration of local scalars FPWR1FLD.90
FPWR1FLD.91
integer ipts ! loop index over unresolved points FPWR1FLD.92
integer isearch ! loop index over calls to spiral_s FPWR1FLD.93
integer nsearch ! # of pts in search "radius" FPWR1FLD.94
integer n_pts_unres ! local counter of # of unresolved points FPWR1FLD.95
integer ncolsOut ! # of columns in output field FPWR1FLD.96
integer nrowsOut ! # of rows in output field FPWR1FLD.97
FPWR1FLD.98
external lsm_set, h_int_lsm, spiral_s, write_pp FPWR1FLD.99
! amend_lookup FPWR1FLD.100
!---------------------------------------------------------------------- FPWR1FLD.101
! 0. Preliminaries FPWR1FLD.102
CSub = 'write_one_field' ! subroutine name for error messages FPWR1FLD.103
FPWR1FLD.104
! 0.1 check that nrows and IGridtype are consistent FPWR1FLD.105
if ( IGridtype .eq. 0 ) then FPWR1FLD.106
FPWR1FLD.107
if ( nrows .ne. nrowst ) then FPWR1FLD.108
icode = 44 FPWR1FLD.109
write(UnErr,*)CErr,CSub, FPWR1FLD.110
# ' 0.1.1 nrows and IGridtype inconsistent: ', FPWR1FLD.111
# ' nrows, nrowst, IGridtype =', nrows, nrowst, IGridtype FPWR1FLD.112
go to 9999 FPWR1FLD.113
end if FPWR1FLD.114
FPWR1FLD.115
else if ( IGridtype .eq. 1 ) then FPWR1FLD.116
FPWR1FLD.117
if ( nrows .ne. nrowsu ) then FPWR1FLD.118
icode = 45 FPWR1FLD.119
write(UnErr,*)CErr,CSub, FPWR1FLD.120
# ' 0.1.2 nrows and IGridtype inconsistent: ', FPWR1FLD.121
# ' nrows, nrowsu, IGridtype =', nrows, nrowsu, IGridtype FPWR1FLD.122
go to 9999 FPWR1FLD.123
end if FPWR1FLD.124
FPWR1FLD.125
else FPWR1FLD.126
FPWR1FLD.127
icode = 46 FPWR1FLD.128
write(UnErr,*)CErr,CSub, FPWR1FLD.129
# ' 0.1.3 not coded for IGridtype =', IGridtype FPWR1FLD.130
go to 9999 FPWR1FLD.131
FPWR1FLD.132
end if ! IGridtype FPWR1FLD.133
FPWR1FLD.134
! 1. Set land points to missing data (use atmosphere grids) FPWR1FLD.135
FPWR1FLD.136
C for tracer grid FPWR1FLD.137
if ( IGridtype .eq. 0 ) then FPWR1FLD.138
call lsm_set( ncols, nrows, lsmt, ILandPt, FPWR1FLD.139
# rmdi, ldebug, field_atm ) FPWR1FLD.140
FPWR1FLD.141
else if ( IGridtype .eq. 1 ) then FPWR1FLD.142
call lsm_set( ncols, nrows, lsmu, ILandPt, FPWR1FLD.143
# rmdi, ldebug, field_atm ) FPWR1FLD.144
FPWR1FLD.145
end if FPWR1FLD.146
FPWR1FLD.147
! 2. Interpolate to ocean grid FPWR1FLD.148
FPWR1FLD.149
if ( IGridtype .eq. 0) then FPWR1FLD.150
FPWR1FLD.151
ncolsOut = ncolsO FPWR1FLD.152
nrowsOut = nrowstO FPWR1FLD.153
call h_int_lsm(nrowst,ncols,ncolsOut*nrowsOut, rmdi, FPWR1FLD.154
# index_bl_t,index_br_t, field_atm, FPWR1FLD.155
# weight_bl_t,weight_br_t,weight_tl_t,weight_tr_t, FPWR1FLD.156
# lsmtO, FPWR1FLD.157
# field_ocean) FPWR1FLD.158
FPWR1FLD.159
else if ( IGridtype .eq. 1) then FPWR1FLD.160
FPWR1FLD.161
ncolsOut = ncolsO FPWR1FLD.162
nrowsOut = nrowsuO FPWR1FLD.163
call h_int_lsm(nrowsu,ncols,ncolsOut*nrowsOut, rmdi, FPWR1FLD.164
# index_bl_u,index_br_u, field_atm, FPWR1FLD.165
# weight_bl_u,weight_br_u,weight_tl_u,weight_tr_u, FPWR1FLD.166
# lsmuO, FPWR1FLD.167
# field_ocean) FPWR1FLD.168
FPWR1FLD.169
end if FPWR1FLD.170
FPWR1FLD.171
! 3. fill in coastal values FPWR1FLD.172
FPWR1FLD.173
! 3.1 for a tracer grid FPWR1FLD.174
if ( IGridtype .eq. 0) then FPWR1FLD.175
FPWR1FLD.176
! 3.1.1 copy unresolved points into a local array (which is FPWR1FLD.177
! updated by each call to spiral_s) FPWR1FLD.178
FPWR1FLD.179
n_pts_unres = n_pts_unres_t FPWR1FLD.180
do ipts = 1, n_pts_unres FPWR1FLD.181
index_unres(ipts) = index_unres_t(ipts) FPWR1FLD.182
end do FPWR1FLD.183
FPWR1FLD.184
! 3.1.2 do spiral searches FPWR1FLD.185
FPWR1FLD.186
do isearch = 1, n_calls_spiral_t FPWR1FLD.187
FPWR1FLD.188
nsearch = n_pts_spiral_t(isearch) FPWR1FLD.189
FPWR1FLD.190
call spiral_s(lsmtO,index_unres,n_pts_unres, FPWR1FLD.191
# nrowsOut,ncolsOut,field_ocean,nsearch,ISeaPt,LCyclic) FPWR1FLD.192
FPWR1FLD.193
end do ! isearch FPWR1FLD.194
FPWR1FLD.195
! 3.2 for a velocity grid FPWR1FLD.196
else if ( IGridtype .eq. 1) then FPWR1FLD.197
FPWR1FLD.198
! 3.2.1 copy unresolved points into a local array (which is FPWR1FLD.199
! updated by each call to spiral_s) FPWR1FLD.200
FPWR1FLD.201
n_pts_unres = n_pts_unres_u FPWR1FLD.202
do ipts = 1, n_pts_unres FPWR1FLD.203
index_unres(ipts) = index_unres_u(ipts) FPWR1FLD.204
end do FPWR1FLD.205
FPWR1FLD.206
! 3.2.2 do spiral searches FPWR1FLD.207
FPWR1FLD.208
do isearch = 1, n_calls_spiral_u FPWR1FLD.209
FPWR1FLD.210
nsearch = n_pts_spiral_u(isearch) FPWR1FLD.211
FPWR1FLD.212
call spiral_s(lsmuO,index_unres,n_pts_unres, FPWR1FLD.213
# nrowsOut,ncolsOut,field_ocean,nsearch,ISeaPt,LCyclic) FPWR1FLD.214
FPWR1FLD.215
end do ! isearch FPWR1FLD.216
FPWR1FLD.217
FPWR1FLD.218
end if ! IGridtype FPWR1FLD.219
FPWR1FLD.220
! 4. Reset missing data values at land points if user has FPWR1FLD.221
! chosen to do so FPWR1FLD.222
FPWR1FLD.223
if ( output_land_value .ne. rmdi ) then FPWR1FLD.224
if ( IGridtype .eq. 0) then FPWR1FLD.225
call lsm_set( ncolsOut, nrowsOut, lsmtO, ILandPt, FPWR1FLD.226
# output_land_value, ldebug, field_ocean ) FPWR1FLD.227
else if ( IGridtype .eq. 1 ) then FPWR1FLD.228
call lsm_set( ncolsOut, nrowsOut, lsmuO, ILandPt, FPWR1FLD.229
# output_land_value, ldebug, field_ocean ) FPWR1FLD.230
end if FPWR1FLD.231
end if FPWR1FLD.232
FPWR1FLD.233
! 5. Amend grid information in lookup table FPWR1FLD.234
if ( IGridtype .eq. 0) then FPWR1FLD.235
call amend_lookup ( LookuplsmtO, Int_Head, Real_Head, FPWR1FLD.236
# output_land_value, FPWR1FLD.237
# StCode, FFCode, PPCode, IVTOffHr ) FPWR1FLD.238
FPWR1FLD.239
else if ( IGridtype .eq. 1 ) then FPWR1FLD.240
call amend_lookup ( LookuplsmuO, Int_Head, Real_Head, FPWR1FLD.241
# output_land_value, FPWR1FLD.242
# StCode, FFCode, PPCode, IVTOffHr ) FPWR1FLD.243
FPWR1FLD.244
end if FPWR1FLD.245
FPWR1FLD.246
! 6. write out filled pp field on ocean grid FPWR1FLD.247
call write_pp(IOutUnit, Int_Head, Real_Head, FPWR1FLD.248
# ncolsOut, nrowsOut, field_ocean, icode) FPWR1FLD.249
if ( icode .gt. 0 ) then FPWR1FLD.250
write(UnErr,*)CErr,CSub, FPWR1FLD.251
# ' step 5. error writing out a pp header and field ' FPWR1FLD.252
go to 9999 FPWR1FLD.253
end if FPWR1FLD.254
FPWR1FLD.255
9999 continue FPWR1FLD.256
return FPWR1FLD.257
end FPWR1FLD.258
!---------------------------------------------------------------------- FPWR1FLD.259
subroutine write_pp ( IOutUnit, Int_Head, Real_Head, 1FPWR1FLD.260
# ncolsOut, nrowsOut, field_out, icode) FPWR1FLD.261
FPWR1FLD.262
FPWR1FLD.263
FPWR1FLD.264
implicit none FPWR1FLD.265
FPWR1FLD.266
! declaration of parameters FPWR1FLD.267
*CALL PLOOKUPS FPWR1FLD.268
FPWR1FLD.269
! declaration of argument list FPWR1FLD.270
integer IOutUnit ! IN output unit number FPWR1FLD.271
integer Int_Head(Len_IntHd) ! integer part of lookup table FPWR1FLD.272
real Real_Head(Len_RealHd) ! real part of lookup table FPWR1FLD.273
integer ncolsOut ! # of columns in output field FPWR1FLD.274
integer nrowsOut ! # of rows in output field FPWR1FLD.275
real field_out( ncolsOut, nrowsOut ) ! field output FPWR1FLD.276
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPWR1FLD.277
FPWR1FLD.278
! declaration of globals used FPWR1FLD.279
*CALL CUNITNOS FPWR1FLD.280
*CALL CMESS FPWR1FLD.281
FPWR1FLD.282
! no local arrays FPWR1FLD.283
FPWR1FLD.284
! declaration of local scalars FPWR1FLD.285
!---------------------------------------------------------------------- FPWR1FLD.286
! 0. Preliminaries FPWR1FLD.287
CSub = 'write_pp' ! subroutine name for error messages FPWR1FLD.288
FPWR1FLD.289
! 1. Write out header FPWR1FLD.290
write (IOutUnit, IOStat = icode) Int_Head, Real_Head FPWR1FLD.291
if ( icode .gt. 0 ) then FPWR1FLD.292
write(UnErr,*)CErr,CSub, FPWR1FLD.293
# ' step 1. error writing out lookup table ' FPWR1FLD.294
icode = 47 FPWR1FLD.295
go to 9999 FPWR1FLD.296
end if FPWR1FLD.297
FPWR1FLD.298
! 2. Write out data FPWR1FLD.299
write (IOutUnit, IOStat = icode) field_out FPWR1FLD.300
if ( icode .gt. 0 ) then FPWR1FLD.301
write(UnErr,*)CErr,CSub, FPWR1FLD.302
# ' step 2. error writing out data field ' FPWR1FLD.303
icode = 48 FPWR1FLD.304
go to 9999 FPWR1FLD.305
end if FPWR1FLD.306
FPWR1FLD.307
9999 continue FPWR1FLD.308
return FPWR1FLD.309
end FPWR1FLD.310
!---------------------------------------------------------------------- FPWR1FLD.311
*ENDIF FPWR1FLD.312