Program MAIN_BCRECONF ,12BCRECON1.23
BCRECON1.24
IMPLICIT NONE BCRECON1.25
! BCRECON1.26
! Description : Reconfigure a boundary dataset according to CHEAD BCRECON1.27
! namelist read in main program. BCRECON1.28
! BCRECON1.29
! Method : Header values in the Fixed Header, Integer Constants or BCRECON1.30
! Real Constants can be changed via Namelist options. BCRECON1.31
! Boundary Data can be vertically interpolated to a new BCRECON1.32
! set of model levels (see subroutine V_INT_INTF). BCRECON1.33
! A new lookup table is created for the output file (see BCRECON1.34
! subroutine NEW_LOOKUP). BCRECON1.35
! BCRECON1.36
! Current Code Owner : Dave Robinson, NWP BCRECON1.37
! BCRECON1.38
! History : BCRECON1.39
! Version Date Comment BCRECON1.40
! ------- ---- ------- BCRECON1.41
! 4.4 10/10/97 Original Code BCRECON1.42
! 4.5 01/10/98 Read in env var UM_SECTOR_SIZE. D. Robinson. UDR3F405.1
! BCRECON1.43
! Code Description : BCRECON1.44
! Language : FORTRAN 77 + common extensions BCRECON1.45
! This code is written to UMDP3 v6 programming standards. BCRECON1.46
! BCRECON1.47
! Declarations : BCRECON1.48
! BCRECON1.49
Integer nftin ! Unit No for input boundary file BCRECON1.50
Integer nftout ! Unit No for output boundary file BCRECON1.51
Integer len_fixh ! Length of fixed header BCRECON1.52
Integer len_inth ! Length of integer constants BCRECON1.53
Integer len_realh ! Length of real constants BCRECON1.54
Integer len1_levdpc_in ! 1st dimension of level dependent BCRECON1.55
! constants in input file BCRECON1.56
Integer len1_levdpc_out ! 1st dimension of level dependent BCRECON1.57
! constants in output file BCRECON1.58
Integer len2_levdpc ! 2nd dimension of level dependent BCRECON1.59
! constants BCRECON1.60
Integer len1_lookup ! 1st dimension of lookup table BCRECON1.61
Integer len2_lookup ! 2nd dimension of lookup table BCRECON1.62
Integer len_data_in ! length of boundary data - input BCRECON1.63
Integer len_data_in_max ! maximum length of input data BCRECON1.64
Integer len_data_out ! length of boundary data - output BCRECON1.65
Integer len_data_out_max ! maximum length of output data BCRECON1.66
Integer p_row_length_in ! row length on P* grid - input BCRECON1.67
Integer u_row_length_in ! row length on U grid - input BCRECON1.68
Integer p_row_length_out ! row length on P* grid - output BCRECON1.69
Integer u_row_length_out ! row length on U grid - output BCRECON1.70
Integer p_rows_in ! no of rows on P* grid - input BCRECON1.71
Integer u_rows_in ! no of rows on U grid - input BCRECON1.72
Integer p_rows_out ! no of rows on P* grid - output BCRECON1.73
Integer u_rows_out ! no of rows on U grid - output BCRECON1.74
Integer p_field_in ! length of data on p grid - input BCRECON1.75
Integer p_field_out ! length of data on p grid - output BCRECON1.76
Integer u_field_in ! length of data on u grid - input BCRECON1.77
Integer u_field_out ! length of data on u grid - output BCRECON1.78
Integer p_levels_in ! no of model levels - input BCRECON1.79
Integer p_levels_out ! no of model levels - output BCRECON1.80
Integer q_levels_in ! no of wet levels - input BCRECON1.81
Integer q_levels_out ! no of wet levels - output BCRECON1.82
Integer tr_levels_in ! no of tracer levels - input BCRECON1.83
Integer tr_levels_out ! no of tracer levels - output BCRECON1.84
Integer tr_vars ! no of tracer variables BCRECON1.85
Integer intf_lookupsa ! no of variables in boundary data BCRECON1.86
Integer rim_width ! Rimwidth in boundary data BCRECON1.87
Integer um_versn ! UM Vn No for output file BCRECON1.88
Integer ipack ! Packing Indicator BCRECON1.89
Integer nq ! No of Q variables in boundary data BCRECON1.90
Integer ppxRecs ! No of stashmaster records BCRECON1.91
Integer icode ! Error code BCRECON1.92
BCRECON1.93
Character*80 cmessage ! Error Message BCRECON1.94
Character*8 c_um_sector_size ! Char variable to read env var UDR3F405.2
BCRECON1.95
Logical lfixh ! T : Reset values in Fixed header BCRECON1.96
Logical linth ! T : Reset values in Integer Constants BCRECON1.97
Logical lrealh ! T : Reset values in Real Constants BCRECON1.98
Logical lvertint ! T : Vertical Interpolate Data BCRECON1.99
Logical lprint ! T : Print max and min values in data BCRECON1.100
Logical l_lspice ! T : Boundary data contains QCF BCRECON1.101
BCRECON1.102
! Required for BUFFOUT routine BCRECON1.103
Integer len_inth_out ! Length of integer constants read in BCRECON1.104
Integer len_lookup ! Length of LOOKUP BCRECON1.105
Integer len_lookup_out ! Length of LOOKUP read in BCRECON1.106
Real status ! Return code BCRECON1.107
BCRECON1.108
Parameter (len_fixh=256) BCRECON1.109
Parameter (len_lookup=64) BCRECON1.110
BCRECON1.111
! Local header arrays BCRECON1.112
Integer fixh_in(len_fixh) ! Fixed header - input BCRECON1.113
Integer inthd(15) ! Integer Constants - input BCRECON1.114
Integer lookup(len_lookup) ! Lookup (One entry) BCRECON1.115
BCRECON1.116
! Required for FILE_OPEN/FILE_CLOSE BCRECON1.117
Integer delete ! Do not delete files BCRECON1.118
Integer read_only ! Input file - read only BCRECON1.119
Integer read_write ! Output file - read & write BCRECON1.120
DATA delete /0/, read_only /0/, read_write /1/ BCRECON1.121
BCRECON1.122
*CALL CSUBMODL 
BCRECON1.123
*CALL C_MDI BCRECON1.124
*CALL CNTL_IO BCRECON1.125
BCRECON1.126
! Namelist : BCRECON1.127
BCRECON1.128
! CHEAD Namelist BCRECON1.129
BCRECON1.130
NAMELIST /CHEAD/ LFIXH, LINTH, LREALH, LVERTINT, LPRINT, BCRECON1.131
* UM_VERSN, IPACK, BCRECON1.132
* P_LEVELS_IN, P_LEVELS_OUT, Q_LEVELS_IN, Q_LEVELS_OUT BCRECON1.133
BCRECON1.134
DATA LFIXH/.FALSE./, LINTH/.FALSE./, LREALH/.FALSE./ BCRECON1.135
DATA LVERTINT/.FALSE./, LPRINT/.FALSE./ BCRECON1.136
DATA UM_VERSN/0/, IPACK/1/ BCRECON1.137
BCRECON1.138
! P_LEVELS_IN and Q_LEVELS_IN are initialised from the input BCRECON1.139
! boundary dataset and do not need to be set in the namelist BCRECON1.140
! unless the boundary dataset was created prior to UM Vn 3.1 BCRECON1.141
BCRECON1.142
! P_LEVELS_OUT and Q_LEVELS_OUT. Only required if vertical BCRECON1.143
! interpolation required to new numbers of model/wet levels. BCRECON1.144
! Otherwise must be set in namelist if input boundary dataset BCRECON1.145
! was created prior to UM Vn 3.1 BCRECON1.146
BCRECON1.147
! LVERTINT must be set a) if changing no of model/wet levels BCRECON1.148
! or b) if re-calculating new Ak and Bk values (with no change BCRECON1.149
! in number of model/wet levels). The Level dependant constants BCRECON1.150
! array is updated. BCRECON1.151
BCRECON1.152
! Function & Subroutine calls BCRECON1.153
BCRECON1.154
EXTERNAL BC_RECONF,FILE_CLOSE,FILE_OPEN,HDPPXRF,READ_FLH BCRECON1.155
BCRECON1.156
!- End of header BCRECON1.157
BCRECON1.158
write (6,*) ' #########################################' BCRECON1.159
write (6,*) ' Running BCRECONF Utility to reconfigure ' BCRECON1.160
write (6,*) ' a Boundary Dataset ' BCRECON1.161
write (6,*) ' #########################################' BCRECON1.162
write (6,*) ' ' BCRECON1.163
BCRECON1.164
icode = 0 BCRECON1.165
BCRECON1.166
! Unit Numbers for input & output boundary datasets BCRECON1.167
nftin =95 BCRECON1.168
nftout=96 BCRECON1.169
BCRECON1.170
! Initialise internal model information BCRECON1.171
! Cater for Atmos model only BCRECON1.172
N_INTERNAL_MODEL=1 BCRECON1.173
INTERNAL_MODEL_INDEX(1)=1 ! Atmos BCRECON1.174
BCRECON1.175
! Determine ppxRecs from Stashmaster files BCRECON1.176
ppxRecs=1 BCRECON1.177
CALL HDPPXRF(22,'STASHmaster_A',ppxRecs,ICODE,CMESSAGE) BCRECON1.178
if (icode.gt.0) then BCRECON1.179
write (6,*) ' Error in HDPPXRF for STASHmaster_A' BCRECON1.180
go to 9999 BCRECON1.181
endif BCRECON1.182
BCRECON1.183
CL UDR3F405.3
CL Get the current sector size for disk I/O UDR3F405.4
CL UDR3F405.5
UDR3F405.6
CALL FORT_GET_ENV('UM_SECTOR_SIZE',14,c_um_sector_size,8,icode) UDR3F405.7
IF (icode .NE. 0) THEN UDR3F405.8
WRITE(6,*) 'Warning : Environment variable UM_SECTOR_SIZE ', UDR3F405.9
& 'has not been set.' UDR3F405.10
WRITE(6,*) 'Setting UM_SECTOR_SIZE to 2048' UDR3F405.11
um_sector_size=2048 UDR3F405.12
ELSE UDR3F405.13
READ(c_um_sector_size,'(I4)') um_sector_size UDR3F405.14
write (6,*) ' ' UDR3F405.15
write (6,*) 'UM_SECTOR_SIZE is set to ',um_sector_size UDR3F405.16
ENDIF UDR3F405.17
UDR3F405.18
! Open input bc file BCRECON1.184
CALL FILE_OPEN (nftin,'BCIN',4,read_only,0,icode) BCRECON1.185
if (icode.ne.0) then BCRECON1.186
write (6,*) ' problem trying to open input boundary dataset' BCRECON1.187
go to 9999 BCRECON1.188
endif BCRECON1.189
BCRECON1.190
! Open output bc file BCRECON1.191
CALL FILE_OPEN (nftout,'BCOUT',5,read_write,0,icode) BCRECON1.192
if (icode.ne.0) then BCRECON1.193
write (6,*) ' problem trying to open output boundary dataset' BCRECON1.194
go to 9999 BCRECON1.195
endif BCRECON1.196
BCRECON1.197
! Read in fixed length header from input file BCRECON1.198
call read_flh (nftin,fixh_in,len_fixh,icode,cmessage) BCRECON1.199
if (icode.gt.0) then BCRECON1.200
write (6,*) ' ' BCRECON1.201
write (6,*) ' Problem reading in fixed length header.' BCRECON1.202
go to 9999 BCRECON1.203
endif BCRECON1.204
BCRECON1.205
! Check for negative dimensions BCRECON1.206
if (fixh_in(101).le.0) fixh_in(101)=1 BCRECON1.207
if (fixh_in(106).le.0) fixh_in(106)=1 BCRECON1.208
if (fixh_in(111).le.0) fixh_in(111)=1 BCRECON1.209
if (fixh_in(112).le.0) fixh_in(112)=1 BCRECON1.210
if (fixh_in(151).le.0) fixh_in(151)=1 BCRECON1.211
if (fixh_in(152).le.0) fixh_in(152)=1 BCRECON1.212
BCRECON1.213
! Get header dimensions BCRECON1.214
len_inth = fixh_in(101) BCRECON1.215
len_realh = fixh_in(106) BCRECON1.216
len1_levdpc_in = fixh_in(111) BCRECON1.217
len2_levdpc = fixh_in(112) BCRECON1.218
len1_lookup = fixh_in(151) BCRECON1.219
len2_lookup = fixh_in(152) BCRECON1.220
BCRECON1.221
! Read in integer constants array BCRECON1.222
call buffin (nftin,inthd,len_inth,len_inth_out,status) BCRECON1.223
if (status.ne.-1.0 .or. len_inth_out.ne.len_inth) then BCRECON1.224
write (6,*) 'problem with reading integer constants array' BCRECON1.225
write (6,*) 'status = ', status BCRECON1.226
write (6,*) 'len_inth = ',len_inth BCRECON1.227
write (6,*) 'len_inth_out = ',len_inth_out BCRECON1.228
go to 9999 BCRECON1.229
endif BCRECON1.230
BCRECON1.231
! Read in first entry in lookup table to get rim_width BCRECON1.232
call setpos (nftin,fixh_in(150)-1,icode) BCRECON1.233
if (icode.gt.0) then BCRECON1.234
write (6,*) 'problem with setpos to first entry from lookup' BCRECON1.235
go to 9999 BCRECON1.236
endif BCRECON1.237
call buffin (nftin,lookup,len_lookup,len_lookup_out,status) BCRECON1.238
if (status.ne.-1.0 .or. len_lookup_out.ne.len_lookup) then BCRECON1.239
write (6,*) 'problem with reading first entry from lookup' BCRECON1.240
write (6,*) 'status = ', status BCRECON1.241
write (6,*) 'len_lookup = ',len_lookup BCRECON1.242
write (6,*) 'len_lookup_out = ',len_lookup_out BCRECON1.243
go to 9999 BCRECON1.244
endif BCRECON1.245
BCRECON1.246
! Get rimwidth BCRECON1.247
rim_width = lookup(18) BCRECON1.248
BCRECON1.249
! Get model grid/levels for input boundary data. BCRECON1.250
p_row_length_in = inthd(6) BCRECON1.251
u_row_length_in = p_row_length_in-1 BCRECON1.252
p_rows_in = inthd(7) BCRECON1.253
u_rows_in = p_rows_in-1 BCRECON1.254
if (fixh_in(12).ge.301) then BCRECON1.255
! Initialise namelist variables BCRECON1.256
p_levels_in = inthd(8) BCRECON1.257
q_levels_in = inthd(9) BCRECON1.258
else BCRECON1.259
p_levels_in = imdi BCRECON1.260
q_levels_in = imdi BCRECON1.261
endif BCRECON1.262
BCRECON1.263
! Default : assume no Vertical Interpolation. BCRECON1.264
p_levels_out = p_levels_in BCRECON1.265
q_levels_out = q_levels_in BCRECON1.266
BCRECON1.267
! Read the namelist BCRECON1.268
read (5,CHEAD) BCRECON1.269
write (6,*) ' ' BCRECON1.270
write (6,*) ' CHEAD Namelist read in is :' BCRECON1.271
write (6,CHEAD) BCRECON1.272
BCRECON1.273
! Check namelist has been set correctly if input boundary BCRECON1.274
! dataset is before Vn 3.1. BCRECON1.275
if (fixh_in(12).lt.301) then BCRECON1.276
if (p_levels_in .eq.imdi .or. q_levels_in .eq.imdi .or. BCRECON1.277
& p_levels_out.eq.imdi .or. q_levels_out.eq.imdi ) then BCRECON1.278
write (6,*) ' ' BCRECON1.279
write (6,*) ' NAMELIST ERROR' BCRECON1.280
write (6,*) ' Input boundary data is for UM Vn ',fixh_in(12) BCRECON1.281
write (6,*) ' All P_LEVELS_IN, Q_LEVELS_IN, P_LEVELS_OUT', BCRECON1.282
& ' and Q_LEVELS_OUT must be specified.' BCRECON1.283
write (6,*) ' P_LEVELS_IN ',P_LEVELS_IN, BCRECON1.284
& ' Q_LEVELS_IN ',Q_LEVELS_IN BCRECON1.285
write (6,*) ' P_LEVELS_OUT ',P_LEVELS_OUT, BCRECON1.286
& ' Q_LEVELS_OUT ',Q_LEVELS_OUT BCRECON1.287
write (6,*) ' Correct namelist and rerun.' BCRECON1.288
go to 9999 BCRECON1.289
endif BCRECON1.290
endif BCRECON1.291
BCRECON1.292
! Check consistency in namelist BCRECON1.293
if (.not.lvertint) then BCRECON1.294
if ( (p_levels_in.ne.p_levels_out) .or. BCRECON1.295
& (q_levels_in.ne.q_levels_out) )then BCRECON1.296
write (6,*) ' ' BCRECON1.297
write (6,*) ' NAMELIST ERROR' BCRECON1.298
write (6,*) ' Vertical Interpolation not required.' BCRECON1.299
write (6,*) ' LVERTINT is ',LVERTINT BCRECON1.300
write (6,*) ' P_LEVELS_IN and/or Q_LEVELS_IN are different', BCRECON1.301
& ' from P_LEVELS_OUT and/or Q_LEVELS_OUT.' BCRECON1.302
write (6,*) ' P_LEVELS_IN ',P_LEVELS_IN, BCRECON1.303
& ' P_LEVELS_OUT ',P_LEVELS_OUT BCRECON1.304
write (6,*) ' Q_LEVELS_IN ',Q_LEVELS_IN, BCRECON1.305
& ' Q_LEVELS_OUT ',Q_LEVELS_OUT BCRECON1.306
write (6,*) ' Correct namelist and rerun.' BCRECON1.307
go to 9999 BCRECON1.308
endif BCRECON1.309
endif BCRECON1.310
BCRECON1.311
if (p_levels_in.ne.len1_levdpc_in) then BCRECON1.312
write (6,*) ' ' BCRECON1.313
write (6,*) ' NAMELIST ERROR' BCRECON1.314
write (6,*) ' Job set up for ',P_LEVELS_IN ,' levels' BCRECON1.315
write (6,*) ' Alabc file set up for ',LEN1_LEVDPC_IN,' levels' BCRECON1.316
write (6,*) ' Provide P_LEVELS_IN with correct no of levels' BCRECON1.317
go to 9999 BCRECON1.318
endif BCRECON1.319
BCRECON1.320
! tr_levels_in = inthd(12) BCRECON1.321
! tr_vars = inthd(14) BCRECON1.322
! Assume no tracers at present. BCRECON1.323
tr_levels_in = 0 BCRECON1.324
tr_vars = 0 BCRECON1.325
BCRECON1.326
! INTHD(15) is correct in boundary datasets from UM Vn 3.3 BCRECON1.327
if(fixh_in(12).ge.303)then BCRECON1.328
intf_lookupsa = inthd(15) BCRECON1.329
else BCRECON1.330
intf_lookupsa = 5 BCRECON1.331
endif BCRECON1.332
BCRECON1.333
l_lspice = intf_lookupsa.eq.6 BCRECON1.334
BCRECON1.335
write (6,*) ' ' BCRECON1.336
write (6,*) ' Packing code IPACK : ',IPACK BCRECON1.337
if (ipack.eq.0) then BCRECON1.338
write (6,*) ' Fields in output file will not be packed.' BCRECON1.339
elseif (ipack.eq.1) then BCRECON1.340
write (6,*) ' Fields in output file will be packed to 32 bits.' BCRECON1.341
elseif (ipack.eq.2) then BCRECON1.342
write (6,*) ' Fields in output file will be packed according', BCRECON1.343
& ' to packing indicator in STASHmaster file.' BCRECON1.344
else BCRECON1.345
write (6,*) ' NAMELIST error' BCRECON1.346
write (6,*) ' IPACK has been set incorrectly.' BCRECON1.347
write (6,*) ' Valid values are 0, 1 and 2.' BCRECON1.348
go to 9999 BCRECON1.349
endif BCRECON1.350
BCRECON1.351
p_row_length_out = p_row_length_in BCRECON1.352
u_row_length_out = u_row_length_in BCRECON1.353
p_rows_out = p_rows_in BCRECON1.354
u_rows_out = u_rows_in BCRECON1.355
tr_levels_out = tr_levels_in BCRECON1.356
BCRECON1.357
! Length of input data fields BCRECON1.358
p_field_in = BCRECON1.359
& ((p_row_length_in+p_rows_in-2*rim_width)*2*rim_width) BCRECON1.360
u_field_in = BCRECON1.361
& ((u_row_length_in+u_rows_in-2*rim_width)*2*rim_width) BCRECON1.362
BCRECON1.363
! Length of output data fields BCRECON1.364
p_field_out = BCRECON1.365
& ((p_row_length_out+p_rows_out-2*rim_width)*2*rim_width) BCRECON1.366
u_field_out = BCRECON1.367
& ((u_row_length_out+u_rows_out-2*rim_width)*2*rim_width) BCRECON1.368
BCRECON1.369
len1_levdpc_out = p_levels_out BCRECON1.370
BCRECON1.371
! Get no of Q fields in Boundary Dataset BCRECON1.372
if (l_lspice) then BCRECON1.373
nq = 2 ! qt and qcf BCRECON1.374
else BCRECON1.375
nq = 1 ! qt BCRECON1.376
endif BCRECON1.377
BCRECON1.378
! Determine length of data for input file BCRECON1.379
len_data_in = p_field_in * BCRECON1.380
+ (p_levels_in+q_levels_in*nq+1+tr_levels_in*tr_vars) + BCRECON1.381
+ u_field_in*(p_levels_in*2) BCRECON1.382
BCRECON1.383
! Determine length of data for output file BCRECON1.384
len_data_out = p_field_out* BCRECON1.385
& (p_levels_out+q_levels_out*nq+1+tr_levels_out*tr_vars) + BCRECON1.386
& u_field_out*(p_levels_out*2) BCRECON1.387
BCRECON1.388
! Round up data lengths to sector boundaries. BCRECON1.389
len_data_in_max = ((len_data_in + um_sector_size - 1)/ BCRECON1.390
& um_sector_size) * um_sector_size BCRECON1.391
len_data_out_max = ((len_data_out + um_sector_size - 1)/ BCRECON1.392
& um_sector_size) * um_sector_size BCRECON1.393
BCRECON1.394
if (fixh_in(12).ge.301) then BCRECON1.395
write (6,*) ' ' BCRECON1.396
write (6,*) ' Input Boundary Dataset for UM Vn ',fixh_in(12) BCRECON1.397
write (6,*) ' p levels in inthd = ',inthd(8) BCRECON1.398
write (6,*) ' q levels in inthd = ',inthd(9) BCRECON1.399
endif BCRECON1.400
BCRECON1.401
write (6,*) ' ' BCRECON1.402
write (6,*) ' Information on input boundary dataset.' BCRECON1.403
write (6,*) ' p_row_length_in = ',p_row_length_in BCRECON1.404
write (6,*) ' u_row_length_in = ',u_row_length_in BCRECON1.405
write (6,*) ' p_rows_in = ',p_rows_in BCRECON1.406
write (6,*) ' u_rows_in = ',u_rows_in BCRECON1.407
write (6,*) ' p_field_in = ',p_field_in BCRECON1.408
write (6,*) ' u_field_in = ',u_field_in BCRECON1.409
write (6,*) ' p_levels_in = ',p_levels_in BCRECON1.410
write (6,*) ' q_levels_in = ',q_levels_in BCRECON1.411
write (6,*) ' tr_levels_in = ',tr_levels_in BCRECON1.412
write (6,*) ' tr_vars = ',tr_vars BCRECON1.413
write (6,*) ' rim_width = ',rim_width BCRECON1.414
write (6,*) ' intf_lookupsa = ',intf_lookupsa BCRECON1.415
write (6,*) ' ' BCRECON1.416
write (6,*) ' Information on output boundary dataset.' BCRECON1.417
write (6,*) ' p_row_length_out = ',p_row_length_out BCRECON1.418
write (6,*) ' u_row_length_out = ',u_row_length_out BCRECON1.419
write (6,*) ' p_rows_out = ',p_rows_out BCRECON1.420
write (6,*) ' u_rows_out = ',u_rows_out BCRECON1.421
write (6,*) ' p_field_out = ',p_field_out BCRECON1.422
write (6,*) ' u_field_out = ',u_field_out BCRECON1.423
write (6,*) ' p_levels_out = ',p_levels_out BCRECON1.424
write (6,*) ' q_levels_out = ',q_levels_out BCRECON1.425
write (6,*) ' tr_levels_out = ',tr_levels_out BCRECON1.426
write (6,*) ' tr_vars = ',tr_vars BCRECON1.427
write (6,*) ' rim_width = ',rim_width BCRECON1.428
write (6,*) ' intf_lookupsa = ',intf_lookupsa BCRECON1.429
write (6,*) ' ' BCRECON1.430
write (6,*) ' Data lengths' BCRECON1.431
write (6,*) ' len_data_in = ',len_data_in BCRECON1.432
write (6,*) ' len_data_out = ',len_data_out BCRECON1.433
! write (6,*) ' len_data_out_max = ',len_data_out_max BCRECON1.434
BCRECON1.435
! Reconfigure the boundary dataset BCRECON1.436
call bc_reconf(nftin,nftout,fixh_in,len_fixh,len_inth, BCRECON1.437
* len_realh,len1_levdpc_in,len1_levdpc_out, BCRECON1.438
* len2_levdpc,len1_lookup,len2_lookup, BCRECON1.439
* len_data_in,len_data_out,len_data_in_max,len_data_out_max, BCRECON1.440
* p_field_in,p_field_out,u_field_in,u_field_out, BCRECON1.441
* p_levels_in,p_levels_out,q_levels_in,q_levels_out, BCRECON1.442
* tr_levels_in,tr_levels_out,tr_vars,intf_lookupsa, BCRECON1.443
* lfixh,linth,lrealh,lvertint,lprint,ipack,l_lspice, BCRECON1.444
* um_versn,ppxRecs,icode,cmessage) BCRECON1.445
BCRECON1.446
BCRECON1.447
if (icode.gt.0) then BCRECON1.448
write (6,*) 'Problem with reconfiguring boundary dataset.' BCRECON1.449
go to 9999 BCRECON1.450
endif BCRECON1.451
BCRECON1.452
! Close input bc file BCRECON1.453
CALL FILE_CLOSE (nftin,'BCIN',4,0,delete,icode) BCRECON1.454
if (icode.ne.0) then BCRECON1.455
write (6,*) ' Problem trying to close input boundary dataset' BCRECON1.456
go to 9999 BCRECON1.457
endif BCRECON1.458
BCRECON1.459
! Close output bc file BCRECON1.460
CALL FILE_CLOSE (nftout,'BCOUT',5,0,delete,icode) BCRECON1.461
if (icode.ne.0) then BCRECON1.462
write (6,*) ' Problem trying to close output boundary dataset' BCRECON1.463
go to 9999 BCRECON1.464
endif BCRECON1.465
BCRECON1.466
9999 continue BCRECON1.467
BCRECON1.468
if (icode.gt.0) then BCRECON1.469
write (6,*) ' ' BCRECON1.470
write (6,*) ' #################################' BCRECON1.471
write (6,*) ' Error in BCRECONF Program.' BCRECON1.472
write (6,*) ' ICODE = ',ICODE BCRECON1.473
write (6,*) ' CMESSAGE = ',CMESSAGE BCRECON1.474
write (6,*) ' #################################' BCRECON1.475
call abort BCRECON1.476
endif BCRECON1.477
BCRECON1.478
write (6,*) ' ' BCRECON1.479
write (6,*) ' ####################################' BCRECON1.480
write (6,*) ' BCRECONF program completed normally.' BCRECON1.481
write (6,*) ' ####################################' BCRECON1.482
BCRECON1.483
stop BCRECON1.484
end BCRECON1.485
BCRECON1.486
!+ Subroutine BC_RECONF : Reconfigures a boundary dataset BCRECON1.487
! BCRECON1.488
! Subroutine Interface : BCRECON1.489
subroutine bc_reconf (nftin,nftout,fixh_in,len_fixh,len_inth, 1,11BCRECON1.490
& len_realh,len1_levdpc_in,len1_levdpc_out, BCRECON1.491
& len2_levdpc,len1_lookup,len2_lookup, BCRECON1.492
& len_data_in,len_data_out, BCRECON1.493
& len_data_in_max,len_data_out_max, BCRECON1.494
& p_field_in,p_field_out,u_field_in,u_field_out, BCRECON1.495
& p_levels_in,p_levels_out,q_levels_in,q_levels_out, BCRECON1.496
& tr_levels_in,tr_levels_out,tr_vars,intf_lookupsa, BCRECON1.497
& lfixh,linth,lrealh,lvertint,lprint,ipack,l_lspice, BCRECON1.498
& um_versn,ppxRecs,icode,cmessage) BCRECON1.499
BCRECON1.500
IMPLICIT NONE BCRECON1.501
! BCRECON1.502
! Description : Reconfigure a boundary dataset according to CHEAD BCRECON1.503
! namelist read in main program. BCRECON1.504
! BCRECON1.505
! Method : Header values in the Fixed Header, Integer Constants or BCRECON1.506
! Real Constants can be changed via Namelist options. BCRECON1.507
! Boundary Data can be vertically interpolated to a new BCRECON1.508
! set of model levels (see subroutine V_INT_INTF). BCRECON1.509
! A new lookup table is created for the output file (see BCRECON1.510
! subroutine NEW_LOOKUP). BCRECON1.511
! BCRECON1.512
! Current Code Owner : Dave Robinson, NWP BCRECON1.513
! BCRECON1.514
! History : BCRECON1.515
! Version Date Comment BCRECON1.516
! ------- ---- ------- BCRECON1.517
! 4.4 10/10/97 Original Code BCRECON1.518
! BCRECON1.519
! Code Description : BCRECON1.520
! Language : FORTRAN 77 + common extensions BCRECON1.521
! This code is written to UMDP3 v6 programming standards. BCRECON1.522
! BCRECON1.523
! Declarations : BCRECON1.524
! BCRECON1.525
! Global Variables : BCRECON1.526
! BCRECON1.527
*CALL CSUBMODL BCRECON1.528
*CALL CPPXREF BCRECON1.529
*CALL PPXLOOK BCRECON1.530
BCRECON1.531
! Subroutine arguments BCRECON1.532
! Scalar arguments with intent(in) : BCRECON1.533
BCRECON1.534
Integer nftin ! Unit No for input boundary file BCRECON1.535
Integer nftout ! Unit No for output boundary file BCRECON1.536
Integer len_fixh ! Length of fixed header BCRECON1.537
Integer len_inth ! Length of integer constants BCRECON1.538
Integer len_realh ! Length of real constants BCRECON1.539
Integer len1_levdpc_in ! 1st dimension of level dependent BCRECON1.540
! constants in input file BCRECON1.541
Integer len1_levdpc_out ! 1st dimension of level dependent BCRECON1.542
! constants in output file BCRECON1.543
Integer len2_levdpc ! 2nd dimension of level dependent BCRECON1.544
! constants BCRECON1.545
Integer len1_lookup ! 1st dimension of lookup table BCRECON1.546
Integer len2_lookup ! 2nd dimension of lookup table BCRECON1.547
Integer len_data_in ! length of boundary data - input BCRECON1.548
Integer len_data_in_max ! maximum length of input data BCRECON1.549
Integer len_data_out ! length of boundary data - output BCRECON1.550
Integer len_data_out_max ! maximum length of output data BCRECON1.551
Integer p_field_in ! length of data on p grid - input BCRECON1.552
Integer p_field_out ! length of data on p grid - output BCRECON1.553
Integer u_field_in ! length of data on u grid - input BCRECON1.554
Integer u_field_out ! length of data on u grid - output BCRECON1.555
Integer p_levels_in ! no of model levels - input BCRECON1.556
Integer p_levels_out ! no of model levels - output BCRECON1.557
Integer q_levels_in ! no of wet levels - input BCRECON1.558
Integer q_levels_out ! no of wet levels - output BCRECON1.559
Integer tr_levels_in ! no of tracer levels - input BCRECON1.560
Integer tr_levels_out ! no of tracer levels - output BCRECON1.561
Integer tr_vars ! no of tracer variables BCRECON1.562
Integer intf_lookupsa ! no of lookup entries for each time BCRECON1.563
Integer um_versn ! UM Vn No for output file BCRECON1.564
Integer ipack ! Packing Indicator BCRECON1.565
BCRECON1.566
Logical lfixh ! T : Reset values in Fixed header BCRECON1.567
Logical linth ! T : Reset values in Integer Constants BCRECON1.568
Logical lrealh ! T : Reset values in Real Constants BCRECON1.569
Logical lvertint ! T : Vertical Interpolate Data BCRECON1.570
Logical lprint ! T : Print max and min values in data BCRECON1.571
Logical l_lspice ! T : Boundary data contains QCF BCRECON1.572
BCRECON1.573
! Array arguments with intent(in) : BCRECON1.574
BCRECON1.575
Integer fixh_in(len_fixh) ! Fixed header - input BCRECON1.576
BCRECON1.577
! Scalar arguments with intent(InOut) : BCRECON1.578
BCRECON1.579
! Array arguments with intent(InOut) : BCRECON1.580
BCRECON1.581
! Scalar arguments with intent(out) : BCRECON1.582
BCRECON1.583
Integer icode ! Error code BCRECON1.584
Character*80 cmessage ! Error Message BCRECON1.585
BCRECON1.586
! Array arguments with intent(out) : BCRECON1.587
BCRECON1.588
! Local parameters : BCRECON1.589
BCRECON1.590
*CALL CLOOKADD BCRECON1.591
*CALL C_MDI BCRECON1.592
*CALL CNTL_IO BCRECON1.593
BCRECON1.594
! Local scalars : BCRECON1.595
BCRECON1.596
Integer i,j,jlev ! Loop indices BCRECON1.597
Integer start_block ! Required for READHEAD BCRECON1.598
Integer ntimes ! No of times boundary data is available BCRECON1.599
Integer irow_number ! Row number, required for GETPPX BCRECON1.600
Integer len_data ! Length of data BCRECON1.601
Integer dummy ! Dummy variable for READHEAD argument list BCRECON1.602
Data dummy /1/ BCRECON1.603
BCRECON1.604
! Local dynamic arrays : BCRECON1.605
BCRECON1.606
! For input file BCRECON1.607
Integer inth_in(len_inth) ! Integer constants BCRECON1.608
Integer lookup_in (fixh_in(151),fixh_in(152)) ! Lookup table BCRECON1.609
Real realh_in(len_realh) ! Real constants BCRECON1.610
Real levdpc_in(len1_levdpc_in,len2_levdpc) ! Level dep consts BCRECON1.611
Real data_in(len_data_in_max) ! Boundary data BCRECON1.612
BCRECON1.613
! For output file BCRECON1.614
Integer fixh_out(len_fixh) ! Fixed header BCRECON1.615
Integer inth_out(len_inth) ! Integer constants BCRECON1.616
Integer lookup_out(fixh_in(151),fixh_in(152)) ! Lookup table BCRECON1.617
Real realh_out(len_realh) ! Real constants BCRECON1.618
Real levdpc_out(len1_levdpc_out,len2_levdpc) ! Level dep consts BCRECON1.619
Real data_out(len_data_out_max) ! Boundary data BCRECON1.620
BCRECON1.621
! Namelists : BCRECON1.622
BCRECON1.623
Integer fixh_new(256) ! Fixed Header BCRECON1.624
NAMELIST /FIXHNEW/ fixh_new BCRECON1.625
BCRECON1.626
Integer inth_new(15) ! Integer Constants BCRECON1.627
NAMELIST /INTHNEW/ inth_new BCRECON1.628
BCRECON1.629
Real realh_new(6) ! Real Constants BCRECON1.630
NAMELIST /REALHNEW/ realh_new BCRECON1.631
BCRECON1.632
! VERTICAL namelist. Only used if UM_VERSN for output boundary BCRECON1.633
! dataset is pre-3.5. From 3.5 onwards, a modified version BCRECON1.634
! of the VERTICAL namelist is read in subroutine BC_ABCALC and BCRECON1.635
! then the Ak and Bk values are calculated. BCRECON1.636
Integer max_n_levs ! Max no of model levels BCRECON1.637
Parameter (max_n_levs = 50) BCRECON1.638
Real ak (max_n_levs) ! Ak at model levels BCRECON1.639
Real bk (max_n_levs) ! Bk at model levels BCRECON1.640
Real akh(max_n_levs+1) ! Ak at model half levels BCRECON1.641
Real bkh(max_n_levs+1) ! Bk at model half levels BCRECON1.642
Real delta_ak(max_n_levs) ! Model Layer Thickness (Ak) BCRECON1.643
Real delta_bk(max_n_levs) ! Model layer Thickness (Bk) BCRECON1.644
Integer vert_coord_type ! Vertical Co-ordinate type BCRECON1.645
NAMELIST /VERTICAL/ VERT_COORD_TYPE,AK,BK,DELTA_AK, BCRECON1.646
& DELTA_BK,AKH,BKH BCRECON1.647
BCRECON1.648
! Function & Subroutine calls BCRECON1.649
BCRECON1.650
EXTERNAL BC_ABCALC,BC_MINMAX,GETPPX,NEW_LOOKUP, BCRECON1.651
& READHEAD,READFLDS,SETPOS,V_INT_INTF,WRITHEAD,WRITFLDS BCRECON1.652
BCRECON1.653
!- End of header BCRECON1.654
BCRECON1.655
! Read in STASHmaster file BCRECON1.656
IROW_NUMBER=0 BCRECON1.657
CALL GETPPX(22,2,'STASHmaster_A',IROW_NUMBER, BCRECON1.658
*CALL ARGPPX BCRECON1.659
& ICODE,CMESSAGE) BCRECON1.660
BCRECON1.661
! 90 format(1x,5i10) BCRECON1.662
! 91 format(1x,5e12.5) BCRECON1.663
92 format(1x,3e22.15) BCRECON1.664
BCRECON1.665
! Initialise namelists BCRECON1.666
do j=1,256 BCRECON1.667
fixh_new(j) = imdi BCRECON1.668
enddo BCRECON1.669
do j=1,15 BCRECON1.670
inth_new(j) = imdi BCRECON1.671
enddo BCRECON1.672
do j=1,6 BCRECON1.673
realh_new(j) = rmdi BCRECON1.674
enddo BCRECON1.675
do jlev=1,max_n_levs BCRECON1.676
ak(jlev) = rmdi BCRECON1.677
bk(jlev) = rmdi BCRECON1.678
enddo BCRECON1.679
do jlev=1,max_n_levs+1 BCRECON1.680
akh(jlev) = rmdi BCRECON1.681
bkh(jlev) = rmdi BCRECON1.682
enddo BCRECON1.683
BCRECON1.684
len_data = fixh_in(161) BCRECON1.685
BCRECON1.686
! return to start of file attached to nftin BCRECON1.687
call setpos (nftin,0,icode) BCRECON1.688
if (icode.gt.0) then BCRECON1.689
write (6,*) ' ' BCRECON1.690
write (6,*) ' Problem with SETPOS before READHEAD.' BCRECON1.691
go to 9999 ! Return BCRECON1.692
endif BCRECON1.693
BCRECON1.694
! Read in the headers BCRECON1.695
call readhead (nftin, BCRECON1.696
& fixh_in,len_fixh, BCRECON1.697
& inth_in,len_inth, BCRECON1.698
& realh_in,len_realh, BCRECON1.699
& levdpc_in,len1_levdpc_in,len2_levdpc, BCRECON1.700
& dummy,dummy,dummy, BCRECON1.701
& dummy,dummy,dummy, BCRECON1.702
& dummy,dummy,dummy, BCRECON1.703
& dummy,dummy, BCRECON1.704
& dummy,dummy, BCRECON1.705
& dummy,dummy, BCRECON1.706
& dummy,dummy, BCRECON1.707
& dummy,dummy, BCRECON1.708
& lookup_in,len1_lookup,len2_lookup, BCRECON1.709
& len_data, BCRECON1.710
*CALL ARGPPX BCRECON1.711
& start_block,icode,cmessage) BCRECON1.712
BCRECON1.713
if (icode.gt.0) then BCRECON1.714
write (6,*) ' Problem in READHEAD.' BCRECON1.715
go to 9999 ! Return BCRECON1.716
endif BCRECON1.717
BCRECON1.718
! write(6,*) 'FIXED HEADER IN /' BCRECON1.719
! write(6,90) fixh_in BCRECON1.720
BCRECON1.721
do i=1,len_fixh BCRECON1.722
fixh_out(i)=fixh_in(i) BCRECON1.723
enddo BCRECON1.724
BCRECON1.725
if (LFIXH) then BCRECON1.726
BCRECON1.727
write(6,*) '===================================================' BCRECON1.728
write(6,*) '=##########RESETTING FIXED HEADER VALUES##########=' BCRECON1.729
write(6,*) '===================================================' BCRECON1.730
read(5,FIXHNEW) BCRECON1.731
BCRECON1.732
do i=1,len_fixh BCRECON1.733
if (fixh_new(i).ne.imdi) then BCRECON1.734
write (6,*) ' Resetting FIXH(',i,') from ',fixh_out(i), BCRECON1.735
& ' to ',fixh_new(i) BCRECON1.736
fixh_out(i) = fixh_new(i) BCRECON1.737
endif BCRECON1.738
enddo BCRECON1.739
BCRECON1.740
endif BCRECON1.741
BCRECON1.742
! Reset model version number if necessary BCRECON1.743
if (um_versn.ne.0) then BCRECON1.744
fixh_out(12) = um_versn BCRECON1.745
write (6,*) ' ' BCRECON1.746
write (6,*) 'UM Vn Number in boundary dataset changed from ', BCRECON1.747
& fixh_in(12),' to ',fixh_out(12) BCRECON1.748
else BCRECON1.749
um_versn = fixh_out(12) BCRECON1.750
write (6,*) ' ' BCRECON1.751
write (6,*) 'UM Vn Number in boundary dataset unchanged ', BCRECON1.752
& fixh_out(12) BCRECON1.753
endif BCRECON1.754
BCRECON1.755
! Set dimensions of arrays in output fixed length header BCRECON1.756
fixh_out(101) = len_inth BCRECON1.757
fixh_out(106) = len_realh BCRECON1.758
fixh_out(111) = len1_levdpc_out BCRECON1.759
fixh_out(112) = len2_levdpc BCRECON1.760
fixh_out(151) = len1_lookup BCRECON1.761
fixh_out(152) = len2_lookup BCRECON1.762
BCRECON1.763
! Set up start addresses for arrays in output fixed length header BCRECON1.764
fixh_out(100) = len_fixh+1 BCRECON1.765
fixh_out(105) = fixh_out(100)+fixh_out(101) BCRECON1.766
fixh_out(110) = fixh_out(105)+fixh_out(106) BCRECON1.767
fixh_out(150) = fixh_out(110)+fixh_out(111)*fixh_out(112) BCRECON1.768
fixh_out(160) = fixh_out(150)+fixh_out(151)*fixh_out(152) BCRECON1.769
BCRECON1.770
! For well formed datasets, data starts on a sector boundary BCRECON1.771
if (um_versn.ge.404) then BCRECON1.772
fixh_out(160) = ((fixh_out(160) + um_sector_size - 1)/ BCRECON1.773
& um_sector_size) * um_sector_size + 1 BCRECON1.774
endif BCRECON1.775
BCRECON1.776
! Set length of data section for output data BCRECON1.777
ntimes = inth_in(3) BCRECON1.778
if(fixh_out(12).lt.304)then BCRECON1.779
len_data = (len_data_out+1)/2 BCRECON1.780
else BCRECON1.781
len_data = len_data_out BCRECON1.782
endif BCRECON1.783
fixh_out(161) = ntimes * len_data BCRECON1.784
BCRECON1.785
! write (6,*) ' ' BCRECON1.786
! write(6,*) 'FIXED HEADER OUT /' BCRECON1.787
! write(6,90) fixh_out BCRECON1.788
BCRECON1.789
! *** Changes for Vn 3.2 *** BCRECON1.790
if (fixh_out(12).ge.302 .and. fixh_in(12).lt.302) then BCRECON1.791
write (6,*) BCRECON1.792
write (6,*) ' Changes for UM Version 3.2' BCRECON1.793
write (6,*) ' ==========================' BCRECON1.794
if (fixh_in(9).ne.2) then BCRECON1.795
write (6,*) ' fix header (9) reset from ',fixh_in(9),' to 2' BCRECON1.796
fixh_out(9) = 2 BCRECON1.797
endif BCRECON1.798
BCRECON1.799
do j=1,len_realh BCRECON1.800
if (realh_in(j).eq.-32768.0) then BCRECON1.801
write (6,*) ' realh(',j,') reset from ', BCRECON1.802
& realh_in(j),' to -2**10' BCRECON1.803
realh_in(j) = rmdi BCRECON1.804
endif BCRECON1.805
enddo BCRECON1.806
BCRECON1.807
do j=1,len2_levdpc BCRECON1.808
do i=1,len1_levdpc_in BCRECON1.809
if (levdpc_in(i,j).eq.-32768.0) then BCRECON1.810
write (6,*) ' levdpc_in(',i,',',j,') reset from ', BCRECON1.811
& levdpc_in(i,j),' to -2**10' BCRECON1.812
levdpc_in(i,j) = rmdi BCRECON1.813
endif BCRECON1.814
enddo BCRECON1.815
enddo BCRECON1.816
BCRECON1.817
do j=1,len2_lookup BCRECON1.818
if (lookup_in(30,j).eq.-32768) then BCRECON1.819
write (6,*) ' lookup(30,',j,') reset from ', BCRECON1.820
& lookup_in(30,j),' to 0' BCRECON1.821
lookup_in(30,j) = 0 BCRECON1.822
endif BCRECON1.823
enddo BCRECON1.824
BCRECON1.825
endif ! End of changes for Vn 3.2 BCRECON1.826
BCRECON1.827
! lpack32 = .true. BCRECON1.828
! if (lpack32) then BCRECON1.829
! if (fixh_out(12).lt.208) then BCRECON1.830
! ipack = -2 BCRECON1.831
! endif BCRECON1.832
! elseif (fixh_out(12).ge.208) then BCRECON1.833
! ipack_out = 2 BCRECON1.834
! endif BCRECON1.835
! else BCRECON1.836
! ipack_out = 0 BCRECON1.837
! endif BCRECON1.838
BCRECON1.839
! No changes for 4.1 in fixh,inthd,realhd,levdepc BCRECON1.840
! Only addresses in LOOKUP Table. BCRECON1.841
! Done in NEW_LOOKUP BCRECON1.842
BCRECON1.843
! No changes for 4.3 BCRECON1.844
BCRECON1.845
! No changes for 4.4 BCRECON1.846
BCRECON1.847
BCRECON1.848
C******** INTEGER CONSTANTS ****************** BCRECON1.849
! write(6,*) 'INTEGER HEADER IN/' BCRECON1.850
! write(6,90) (inth_in(i),i=1,len_inth) BCRECON1.851
BCRECON1.852
do i=1,len_inth BCRECON1.853
inth_out(i)=inth_in(i) BCRECON1.854
enddo BCRECON1.855
BCRECON1.856
if (linth) then BCRECON1.857
BCRECON1.858
write(6,*) '================================================' BCRECON1.859
write(6,*) '=#####RESETTING INTEGER HEADER VALUES##########=' BCRECON1.860
write(6,*) '================================================' BCRECON1.861
read(5,INTHNEW) BCRECON1.862
BCRECON1.863
do i=1,len_inth BCRECON1.864
if (inth_new(i).ne.imdi) then BCRECON1.865
write (6,*) ' Resetting INTH(',i,') from ',inth_out(i), BCRECON1.866
& ' to ',inth_new(i) BCRECON1.867
inth_out(i) = inth_new(i) BCRECON1.868
endif BCRECON1.869
enddo BCRECON1.870
BCRECON1.871
endif BCRECON1.872
BCRECON1.873
C Set no of model levels to no of levels in output data. BCRECON1.874
if (inth_out(8).ne.p_levels_out) then BCRECON1.875
write (6,*) 'inth(8) (p_levels) set to ',p_levels_out BCRECON1.876
inth_out(8) = p_levels_out BCRECON1.877
endif BCRECON1.878
if (inth_out(9).ne.q_levels_out) then BCRECON1.879
write (6,*) 'inth(9) (q_levels) set to ',q_levels_out BCRECON1.880
inth_out(9) = q_levels_out BCRECON1.881
endif BCRECON1.882
BCRECON1.883
! write(6,*) 'INTEGER HEADER OUT/' BCRECON1.884
! write(6,90) (inth_out(i),i=1,len_inth) BCRECON1.885
BCRECON1.886
C******** REAL CONSTANTS ****************** BCRECON1.887
! write(6,*) 'REAL HEADER IN/' BCRECON1.888
! write(6,91) (realh_in(i),i=1,len_realh) BCRECON1.889
BCRECON1.890
do i=1,len_realh BCRECON1.891
realh_out(i)=realh_in(i) BCRECON1.892
enddo BCRECON1.893
BCRECON1.894
if (lrealh) then BCRECON1.895
BCRECON1.896
write(6,*) '================================================' BCRECON1.897
write(6,*) '=#####RESETTING REAL HEADER VALUES#############=' BCRECON1.898
write(6,*) '================================================' BCRECON1.899
read(5,REALHNEW) BCRECON1.900
BCRECON1.901
do i=1,len_realh BCRECON1.902
if (realh_new(i).ne.rmdi) then BCRECON1.903
write (6,*) ' Resetting REALH(',i,') from ',realh_out(i), BCRECON1.904
& ' to ',realh_new(i) BCRECON1.905
realh_out(i) = realh_new(i) BCRECON1.906
endif BCRECON1.907
enddo BCRECON1.908
BCRECON1.909
endif BCRECON1.910
BCRECON1.911
! write(6,*) 'REAL HEADER OUT /' BCRECON1.912
! write(6,91) (realh_out(i),i=1,len_realh) BCRECON1.913
BCRECON1.914
C******** LEVDEP CONSTANTS ****************** BCRECON1.915
BCRECON1.916
! do j=1,len2_levdpc BCRECON1.917
! write(6,*) ' LEVEL dependent constants IN; position=',j BCRECON1.918
! write(6,92) (levdpc_in(i,j),i=1,len1_levdpc_in) BCRECON1.919
! enddo BCRECON1.920
BCRECON1.921
if (lvertint) then BCRECON1.922
BCRECON1.923
write(6,*) '===================================================' BCRECON1.924
write(6,*) '=########RESETTING LEVEL DEPENDENT CONSTANTS######=' BCRECON1.925
write(6,*) '===================================================' BCRECON1.926
if (um_versn.ge.305) then BCRECON1.927
BCRECON1.928
call bc_abcalc (ak,bk,akh,bkh,len1_levdpc_out, BCRECON1.929
& icode,cmessage) BCRECON1.930
BCRECON1.931
if (icode.gt.0) then BCRECON1.932
write (6,*) ' Error in BC_ABCALC.' BCRECON1.933
go to 9999 ! Return BCRECON1.934
endif BCRECON1.935
BCRECON1.936
else ! UM pre 3.5/4.0 BCRECON1.937
BCRECON1.938
read (5,VERTICAL) BCRECON1.939
write(6, VERTICAL) BCRECON1.940
rewind 5 BCRECON1.941
BCRECON1.942
write(6,*) ' AK in namelist' BCRECON1.943
write(6,92) (ak(i),i=1,len1_levdpc_out) BCRECON1.944
write(6,*) ' BK in namelist' BCRECON1.945
write(6,92) (bk(i),i=1,len1_levdpc_out) BCRECON1.946
write(6,*) ' AKH in namelist' BCRECON1.947
write(6,92) (akh(i),i=1,len1_levdpc_out+1) BCRECON1.948
write(6,*) ' BKH in namelist' BCRECON1.949
write(6,92) (bkh(i),i=1,len1_levdpc_out+1) BCRECON1.950
BCRECON1.951
endif BCRECON1.952
BCRECON1.953
do i=1,len1_levdpc_out BCRECON1.954
BCRECON1.955
if (ak(i).ne.rmdi) then BCRECON1.956
levdpc_out(i,1) = ak(i) BCRECON1.957
else BCRECON1.958
if (i.le.len1_levdpc_in) levdpc_out(i,1) = levdpc_in(i,1) BCRECON1.959
endif BCRECON1.960
if (bk(i).ne.rmdi) then BCRECON1.961
levdpc_out(i,2) = bk(i) BCRECON1.962
else BCRECON1.963
if (i.le.len1_levdpc_in) levdpc_out(i,2) = levdpc_in(i,2) BCRECON1.964
endif BCRECON1.965
if (akh(i).ne.rmdi .and. akh(i+1).ne.rmdi) then BCRECON1.966
levdpc_out(i,3) = akh(i+1) - akh(i) BCRECON1.967
else BCRECON1.968
if (i.le.len1_levdpc_in) levdpc_out(i,3) = levdpc_in(i,3) BCRECON1.969
endif BCRECON1.970
if (bkh(i).ne.rmdi .and. bkh(i+1).ne.rmdi) then BCRECON1.971
levdpc_out(i,4) = bkh(i+1) - bkh(i) BCRECON1.972
else BCRECON1.973
if (i.le.len1_levdpc_in) levdpc_out(i,4) = levdpc_in(i,4) BCRECON1.974
endif BCRECON1.975
BCRECON1.976
enddo BCRECON1.977
BCRECON1.978
else ! lvertint=f BCRECON1.979
BCRECON1.980
if (len1_levdpc_in.eq.len1_levdpc_out) then BCRECON1.981
BCRECON1.982
do j=1,len2_levdpc BCRECON1.983
do i=1,len1_levdpc_out BCRECON1.984
levdpc_out(i,j)=levdpc_in(i,j) BCRECON1.985
enddo BCRECON1.986
enddo BCRECON1.987
BCRECON1.988
else BCRECON1.989
BCRECON1.990
write (6,*) 'lvertint = f' BCRECON1.991
write (6,*) 'len1_levdpc_in NE len1_levdpc_out ????' BCRECON1.992
BCRECON1.993
endif BCRECON1.994
BCRECON1.995
endif BCRECON1.996
BCRECON1.997
! do j=1,len2_levdpc BCRECON1.998
! write(6,*) ' LEVEL dependent constants OUT; position=',j BCRECON1.999
! write(6,92) (levdpc_out(i,j),i=1,len1_levdpc_out) BCRECON1.1000
! enddo BCRECON1.1001
BCRECON1.1002
! Set up lookup table for output boundary dataset BCRECON1.1003
call new_lookup ( BCRECON1.1004
*CALL ARGPPX BCRECON1.1005
& lookup_in,lookup_in,lookup_out,lookup_out, BCRECON1.1006
& len1_lookup,len2_lookup,len_data_out, BCRECON1.1007
& p_field_out,u_field_out, BCRECON1.1008
& p_levels_out,q_levels_out,tr_levels_out,tr_vars, BCRECON1.1009
& ipack,intf_lookupsa,um_versn,l_lspice,fixh_out(160), BCRECON1.1010
& icode,cmessage) BCRECON1.1011
BCRECON1.1012
if (icode.gt.0) then BCRECON1.1013
write (6,*) ' ERROR in NEW_LOOKUP' BCRECON1.1014
go to 9999 ! Return BCRECON1.1015
endif BCRECON1.1016
BCRECON1.1017
! Write out headers to output boundary dataset BCRECON1.1018
len_data = fixh_out(161) BCRECON1.1019
BCRECON1.1020
call writhead (nftout, BCRECON1.1021
& fixh_out,len_fixh, BCRECON1.1022
& inth_out,len_inth, BCRECON1.1023
& realh_out,len_realh, BCRECON1.1024
& levdpc_out,len1_levdpc_out,len2_levdpc, BCRECON1.1025
& dummy,dummy,dummy, BCRECON1.1026
& dummy,dummy,dummy, BCRECON1.1027
& dummy,dummy,dummy, BCRECON1.1028
& dummy,dummy, BCRECON1.1029
& dummy,dummy, BCRECON1.1030
& dummy,dummy, BCRECON1.1031
& dummy,dummy, BCRECON1.1032
& dummy,dummy, BCRECON1.1033
& lookup_out,len1_lookup,len2_lookup, BCRECON1.1034
& len_data, BCRECON1.1035
*CALL ARGPPX BCRECON1.1036
& start_block,icode,cmessage) BCRECON1.1037
BCRECON1.1038
if (icode.gt.0) then BCRECON1.1039
write (6,*) ' Problem in WRITHEAD.' BCRECON1.1040
go to 9999 ! Return BCRECON1.1041
endif BCRECON1.1042
BCRECON1.1043
! Now process the data BCRECON1.1044
BCRECON1.1045
if (lvertint) then BCRECON1.1046
write(6,*) '=================================================' BCRECON1.1047
write(6,*) '=#### VERTICALLY INTERPOLATE BOUNDARY DATA #####=' BCRECON1.1048
write(6,*) '=================================================' BCRECON1.1049
endif BCRECON1.1050
BCRECON1.1051
! start_address_in = fixh_in (160)-1 BCRECON1.1052
! start_address_out = fixh_out(160)-1 BCRECON1.1053
BCRECON1.1054
do j=1,len2_lookup,intf_lookupsa BCRECON1.1055
BCRECON1.1056
! if(fixh_in(12).lt.304)then BCRECON1.1057
! ipos = start_address_in + lookup_in(naddr,j) - 1 BCRECON1.1058
! else BCRECON1.1059
! if (lpack32) then BCRECON1.1060
! ipos = start_address_in + (lookup_in(naddr,j) + 1) / 2 -1 BCRECON1.1061
! else BCRECON1.1062
! ipos = start_address_in + lookup_in(naddr,j) -1 BCRECON1.1063
! endif BCRECON1.1064
! endif BCRECON1.1065
! write (6,*) ' j ipos ',j,ipos BCRECON1.1066
! call setpos(nftin,ipos,icode) BCRECON1.1067
BCRECON1.1068
call readflds (nftin,intf_lookupsa,j,lookup_in,len1_lookup, BCRECON1.1069
& data_in,len_data_in,fixh_in, BCRECON1.1070
*CALL ARGPPX BCRECON1.1071
& icode,cmessage) BCRECON1.1072
BCRECON1.1073
if (icode.gt.0) then BCRECON1.1074
write (6,*) ' Problem with reading input data in READFLDS.' BCRECON1.1075
write (6,*) ' Attempting to read ',intf_lookupsa, BCRECON1.1076
& ' fields starting at lookup position ',j BCRECON1.1077
go to 9999 ! Return BCRECON1.1078
endif BCRECON1.1079
BCRECON1.1080
if (lprint .and. BCRECON1.1081
& (j.eq.1 .or. j.eq.len2_lookup-intf_lookupsa+1) ) then BCRECON1.1082
BCRECON1.1083
C print max/min of fields BCRECON1.1084
write(6,*) ' data in ,J=',j BCRECON1.1085
call bc_minmax BCRECON1.1086
& (p_field_in,u_field_in,p_levels_in,q_levels_in, BCRECON1.1087
& tr_levels_in,tr_vars,data_in,len_data_in,l_lspice) BCRECON1.1088
BCRECON1.1089
endif !lprint BCRECON1.1090
BCRECON1.1091
if (lvertint) then BCRECON1.1092
BCRECON1.1093
! Do Vertical Interpolation BCRECON1.1094
BCRECON1.1095
call V_INT_INTF(data_in,levdpc_in(1,1),levdpc_in(1,2), BCRECON1.1096
& p_levels_in,q_levels_in,TR_VARS,tr_levels_in, BCRECON1.1097
& p_field_in,u_field_in, BCRECON1.1098
& data_out,levdpc_out(1,1),levdpc_out(1,2), BCRECON1.1099
& p_levels_out,q_levels_out,tr_levels_out, BCRECON1.1100
& l_lspice,icode,cmessage) BCRECON1.1101
BCRECON1.1102
if (icode.gt.0) then BCRECON1.1103
write (6,*) ' Problem with Vertical Interpolation.' BCRECON1.1104
write (6,*) ' Attempting to interpolate data corresponding', BCRECON1.1105
& ' to Lookup Position ',j BCRECON1.1106
go to 9999 ! Return BCRECON1.1107
endif BCRECON1.1108
BCRECON1.1109
if (lprint .and. BCRECON1.1110
& (j.eq.1 .or. j.eq.len2_lookup-intf_lookupsa+1) ) then BCRECON1.1111
BCRECON1.1112
write(6,*) ' data out ,J=',j BCRECON1.1113
call bc_minmax BCRECON1.1114
& (p_field_out,u_field_out,p_levels_out,q_levels_out, BCRECON1.1115
& tr_levels_out,tr_vars,data_out,len_data_out,l_lspice) BCRECON1.1116
BCRECON1.1117
endif !lprint BCRECON1.1118
BCRECON1.1119
else BCRECON1.1120
BCRECON1.1121
do i=1,len_data_in BCRECON1.1122
data_out(i) = data_in(i) BCRECON1.1123
enddo BCRECON1.1124
BCRECON1.1125
endif !lvertint BCRECON1.1126
BCRECON1.1127
! if(fixh_out(12).lt.304)then BCRECON1.1128
! ipos = start_address_out + lookup_out(naddr,j) - 1 BCRECON1.1129
! else BCRECON1.1130
! if (lpack32) then BCRECON1.1131
! ipos = start_address_out + (lookup_out(naddr,j) + 1) / 2 - 1 BCRECON1.1132
! else BCRECON1.1133
! ipos = start_address_out + lookup_out(naddr,j) -1 BCRECON1.1134
! endif BCRECON1.1135
! endif BCRECON1.1136
! call setpos (nftout,ipos,icode) BCRECON1.1137
BCRECON1.1138
call writflds (nftout,intf_lookupsa,j,lookup_out,len1_lookup, BCRECON1.1139
& data_out,len_data_out,fixh_out, BCRECON1.1140
*CALL ARGPPX BCRECON1.1141
& icode,cmessage) BCRECON1.1142
BCRECON1.1143
if (icode.gt.0) then BCRECON1.1144
write (6,*) ' Problem with writing output data in WRITFLDS.' BCRECON1.1145
write (6,*) ' Attempting to write ',intf_lookupsa, BCRECON1.1146
& ' fields starting at lookup position ',j BCRECON1.1147
go to 9999 ! Return BCRECON1.1148
endif BCRECON1.1149
BCRECON1.1150
enddo ! end of lookup header/data loop j BCRECON1.1151
BCRECON1.1152
9999 continue BCRECON1.1153
BCRECON1.1154
return BCRECON1.1155
end BCRECON1.1156
BCRECON1.1157
BCRECON1.1158
!+ Subroutine NEW_LOOKUP : Create a new lookup table. BCRECON1.1159
! BCRECON1.1160
! Subroutine Interface : BCRECON1.1161
subroutine new_lookup ( 1,1BCRECON1.1162
*CALL ARGPPX BCRECON1.1163
& ilookup_in,rlookup_in, BCRECON1.1164
& ilookup_out,rlookup_out, BCRECON1.1165
& len1_lookup,len2_lookup,len_data_out, BCRECON1.1166
& p_field_out,u_field_out, BCRECON1.1167
& p_levels_out,q_levels_out,tr_levels_out,tr_vars, BCRECON1.1168
& ipack,intf_lookupsa,um_versn,l_lspice,fixh_160, BCRECON1.1169
& icode,cmessage) BCRECON1.1170
BCRECON1.1171
IMPLICIT NONE BCRECON1.1172
! BCRECON1.1173
! Description : Creates a new lookup table for the output BCRECON1.1174
! boundary dataset. BCRECON1.1175
! BCRECON1.1176
! Method : Output lookup table is initialised from input table. BCRECON1.1177
! Output lookup table is then reset as required. It caters BCRECON1.1178
! for changes in no of model/wet levels. BCRECON1.1179
! BCRECON1.1180
! Current Code Owner : Dave Robinson, NWP BCRECON1.1181
! BCRECON1.1182
! History : BCRECON1.1183
! Version Date Comment BCRECON1.1184
! ------- ---- ------- BCRECON1.1185
! 4.4 10/10/97 Original Code BCRECON1.1186
! BCRECON1.1187
! Code Description : BCRECON1.1188
! Language : FORTRAN 77 + common extensions BCRECON1.1189
! This code is written to UMDP3 v6 programming standards. BCRECON1.1190
! BCRECON1.1191
! Declarations : BCRECON1.1192
! BCRECON1.1193
! Global Variables : BCRECON1.1194
! BCRECON1.1195
*CALL CSUBMODL BCRECON1.1196
*CALL CPPXREF BCRECON1.1197
*CALL PPXLOOK BCRECON1.1198
! BCRECON1.1199
! Subroutine arguments BCRECON1.1200
! Scalar arguments with intent(in) : BCRECON1.1201
BCRECON1.1202
Integer len1_lookup ! 1st dimension of LOOKUP BCRECON1.1203
Integer len2_lookup ! 2nd dimension of LOOKUP BCRECON1.1204
Integer len_data_out ! Length of output data BCRECON1.1205
Integer p_field_out ! Length of field on P* grid BCRECON1.1206
Integer u_field_out ! Length of field on U grid BCRECON1.1207
Integer p_levels_out ! No of model levels in output BCRECON1.1208
Integer q_levels_out ! No of wet levels in output BCRECON1.1209
Integer tr_levels_out ! No of tracer levels in output BCRECON1.1210
Integer tr_vars ! No of tracer variables BCRECON1.1211
Integer ipack ! Packing Indicator BCRECON1.1212
Integer intf_lookupsa ! No of variables in boundary data BCRECON1.1213
Integer um_versn ! No of variables in boundary data BCRECON1.1214
Integer fixh_160 ! Copy of fixh_out(160) BCRECON1.1215
BCRECON1.1216
Logical l_lspice ! T : Boundary data contains QCF BCRECON1.1217
BCRECON1.1218
! Array arguments with intent(in) : BCRECON1.1219
BCRECON1.1220
! For input file BCRECON1.1221
Integer ilookup_in (len1_lookup,len2_lookup) ! Integer LOOKUP BCRECON1.1222
Real rlookup_in (len1_lookup,len2_lookup) ! Real LOOKUP BCRECON1.1223
BCRECON1.1224
! Scalar arguments with intent(InOut) : BCRECON1.1225
BCRECON1.1226
! Array arguments with intent(InOut) : BCRECON1.1227
BCRECON1.1228
! Scalar arguments with intent(out) : BCRECON1.1229
BCRECON1.1230
Integer icode ! Error code BCRECON1.1231
Character*80 cmessage ! Error Message BCRECON1.1232
BCRECON1.1233
! Array arguments with intent(out) : BCRECON1.1234
BCRECON1.1235
! For output file BCRECON1.1236
Integer ilookup_out(len1_lookup,len2_lookup) ! Integer LOOKUP BCRECON1.1237
Real rlookup_out(len1_lookup,len2_lookup) ! Real LOOKUP BCRECON1.1238
BCRECON1.1239
! Local parameters : BCRECON1.1240
BCRECON1.1241
*CALL CLOOKADD BCRECON1.1242
*CALL CNTL_IO BCRECON1.1243
BCRECON1.1244
! Local scalars : BCRECON1.1245
BCRECON1.1246
Integer i,j,var ! Loop indexes BCRECON1.1247
Integer npack ! Packing indicator BCRECON1.1248
Integer len_data ! Length of data BCRECON1.1249
Integer len_field ! Length of field BCRECON1.1250
Integer start_address ! Start address in lookup(40) BCRECON1.1251
Integer disk_address ! Disk address BCRECON1.1252
Integer disk_length ! Data record length on disk BCRECON1.1253
BCRECON1.1254
! Local dynamic arrays : BCRECON1.1255
BCRECON1.1256
integer item_intfa(intf_lookupsa) ! Item codes for data BCRECON1.1257
BCRECON1.1258
! Function & Subroutine calls BCRECON1.1259
INTEGER EXPPXI BCRECON1.1260
EXTERNAL EXPPXI BCRECON1.1261
BCRECON1.1262
!- End of header BCRECON1.1263
BCRECON1.1264
! Initialise output lookup table from input lookup table BCRECON1.1265
do j=1,len2_lookup BCRECON1.1266
do i=1,45 BCRECON1.1267
ilookup_out(i,j) = ilookup_in(i,j) BCRECON1.1268
enddo BCRECON1.1269
do i=46,len1_lookup BCRECON1.1270
rlookup_out(i,j) = rlookup_in(i,j) BCRECON1.1271
enddo BCRECON1.1272
enddo BCRECON1.1273
BCRECON1.1274
! Set up stash codes BCRECON1.1275
item_intfa(1) = 1 ! pstar BCRECON1.1276
item_intfa(2) = 2 ! u BCRECON1.1277
item_intfa(3) = 3 ! v BCRECON1.1278
item_intfa(4) = 5 ! thetal BCRECON1.1279
item_intfa(5) = 11 ! qt BCRECON1.1280
if (l_lspice) then BCRECON1.1281
item_intfa(6+tr_vars) = 12 ! QCF BCRECON1.1282
endif BCRECON1.1283
BCRECON1.1284
start_address = 1 BCRECON1.1285
if(um_versn.lt.304)then BCRECON1.1286
len_data = (len_data_out+1)/2 BCRECON1.1287
else BCRECON1.1288
len_data = len_data_out BCRECON1.1289
endif BCRECON1.1290
BCRECON1.1291
do j=1,len2_lookup,intf_lookupsa BCRECON1.1292
do var=1,intf_lookupsa BCRECON1.1293
if (var.eq.1) then ! p* BCRECON1.1294
len_field = p_field_out BCRECON1.1295
elseif (var.eq.2 .or. var.eq.3) then ! u or v BCRECON1.1296
len_field = u_field_out * p_levels_out BCRECON1.1297
elseif (var.eq.4) then ! thetal BCRECON1.1298
len_field = p_field_out * p_levels_out BCRECON1.1299
elseif (var.eq.5) then ! qt BCRECON1.1300
len_field = p_field_out * q_levels_out BCRECON1.1301
elseif (var.eq.6) then ! qcf BCRECON1.1302
len_field = p_field_out * q_levels_out BCRECON1.1303
endif BCRECON1.1304
ilookup_out(lblrec,j+var-1) = len_field BCRECON1.1305
BCRECON1.1306
if (um_versn.lt.208) then ! Packing indicator if pre 2.8 BCRECON1.1307
npack = -2 BCRECON1.1308
elseif (ipack.eq.0 ) then ! No packing BCRECON1.1309
npack = ipack BCRECON1.1310
elseif (ipack.eq.1) then ! 32 bit packing BCRECON1.1311
npack = 2 BCRECON1.1312
elseif (ipack.eq.2) then ! Use packing info in STASHmaster BCRECON1.1313
npack = EXPPXI(atmos_im,0,item_intfa(var),ppx_dump_packing, BCRECON1.1314
*CALL ARGPPX BCRECON1.1315
& icode,cmessage) BCRECON1.1316
endif BCRECON1.1317
ilookup_out(lbpack,j+var-1) = npack BCRECON1.1318
ilookup_out(naddr,j+var-1) = start_address BCRECON1.1319
if (um_versn.ge.401) then BCRECON1.1320
start_address = start_address+len_field BCRECON1.1321
endif BCRECON1.1322
enddo ! loop over var BCRECON1.1323
BCRECON1.1324
if (um_versn.lt.401) then BCRECON1.1325
start_address = start_address + len_data BCRECON1.1326
endif BCRECON1.1327
BCRECON1.1328
enddo ! loop over j BCRECON1.1329
BCRECON1.1330
! For UM 4.4 onwards, set up boundary dataset to be well-formed BCRECON1.1331
BCRECON1.1332
if (um_versn.ge.404) then ! Boundary dataset well-formed BCRECON1.1333
BCRECON1.1334
disk_address = fixh_160 - 1 BCRECON1.1335
BCRECON1.1336
do j=1,len2_lookup,intf_lookupsa BCRECON1.1337
BCRECON1.1338
disk_address = ((disk_address + um_sector_size - 1)/ BCRECON1.1339
& um_sector_size) * um_sector_size BCRECON1.1340
BCRECON1.1341
do var = 1, intf_lookupsa BCRECON1.1342
disk_length = ilookup_out(lblrec,j+var-1) BCRECON1.1343
if (mod(ilookup_out(lbpack,j+var-1),10).eq.2) then BCRECON1.1344
disk_length = (disk_length+1)/2 BCRECON1.1345
endif BCRECON1.1346
ilookup_out(lbegin,j+var-1) = disk_address BCRECON1.1347
ilookup_out(lbnrec,j+var-1) = disk_length BCRECON1.1348
disk_address = disk_address + disk_length BCRECON1.1349
enddo BCRECON1.1350
enddo BCRECON1.1351
BCRECON1.1352
else ! Boundary dataset not well-formed BCRECON1.1353
BCRECON1.1354
disk_address = 0 BCRECON1.1355
disk_length = 0 BCRECON1.1356
do j=1,len2_lookup BCRECON1.1357
ilookup_out(lbegin,j) = disk_address BCRECON1.1358
ilookup_out(lbnrec,j) = disk_length BCRECON1.1359
enddo BCRECON1.1360
BCRECON1.1361
endif BCRECON1.1362
BCRECON1.1363
return BCRECON1.1364
end BCRECON1.1365
BCRECON1.1366
BCRECON1.1367
!+ Subroutine BC_MINMAX : Calculate max and min values in boundary data BCRECON1.1368
! BCRECON1.1369
! Subroutine Interface : BCRECON1.1370
subroutine bc_minmax (p_field,u_field,p_levels,q_levels, 2,7BCRECON1.1371
+ tr_levels,tr_vars,data,len_data,l_lspice) BCRECON1.1372
implicit none BCRECON1.1373
BCRECON1.1374
! Description : Get min and max values in boundary data. BCRECON1.1375
! BCRECON1.1376
! Method : For each variable, call minmax to get max & min value. BCRECON1.1377
! BCRECON1.1378
! Current Code Owner : Dave Robinson, NWP BCRECON1.1379
! BCRECON1.1380
! History : BCRECON1.1381
! Version Date Comment BCRECON1.1382
! ------- ---- ------- BCRECON1.1383
! 4.4 10/10/97 Original Code BCRECON1.1384
! BCRECON1.1385
! Code Description : BCRECON1.1386
! Language : FORTRAN 77 + common extensions BCRECON1.1387
! This code is written to UMDP3 v6 programming standards. BCRECON1.1388
! BCRECON1.1389
! Declarations : BCRECON1.1390
! BCRECON1.1391
! Global Variables : BCRECON1.1392
! BCRECON1.1393
! Subroutine arguments BCRECON1.1394
! Scalar arguments with intent(in) : BCRECON1.1395
BCRECON1.1396
Integer p_field ! Length of field on P* grid BCRECON1.1397
Integer u_field ! Length of field on U grid BCRECON1.1398
Integer p_levels ! No of model levels BCRECON1.1399
Integer q_levels ! No of wet levels BCRECON1.1400
Integer tr_levels ! No of tracer levels BCRECON1.1401
Integer tr_vars ! No of tracer variables BCRECON1.1402
Integer len_data ! Length of data BCRECON1.1403
BCRECON1.1404
Logical l_lspice ! T : Boundary data contains QCF BCRECON1.1405
BCRECON1.1406
! Array arguments with intent(in) : BCRECON1.1407
BCRECON1.1408
Real data(len_data) ! Boundary data BCRECON1.1409
BCRECON1.1410
! Scalar arguments with intent(InOut) : BCRECON1.1411
BCRECON1.1412
! Array arguments with intent(InOut) : BCRECON1.1413
BCRECON1.1414
! Scalar arguments with intent(out) : BCRECON1.1415
BCRECON1.1416
! Array arguments with intent(out) : BCRECON1.1417
BCRECON1.1418
! Local parameters : BCRECON1.1419
BCRECON1.1420
! Local scalars : BCRECON1.1421
BCRECON1.1422
Integer ipos ! Position in boundary data BCRECON1.1423
Integer itrace ! Loop index BCRECON1.1424
BCRECON1.1425
! Local dynamic arrays : BCRECON1.1426
BCRECON1.1427
! Function & Subroutine calls BCRECON1.1428
BCRECON1.1429
!- End of header BCRECON1.1430
BCRECON1.1431
! PSTAR BCRECON1.1432
write(6,*) ' PSTAR' BCRECON1.1433
ipos=1 BCRECON1.1434
call minmax (data(ipos),p_field,1,1,p_field) BCRECON1.1435
ipos=ipos+p_field BCRECON1.1436
BCRECON1.1437
! U BCRECON1.1438
write(6,*) ' U ' BCRECON1.1439
call minmax (data(ipos),u_field,p_levels,1,u_field) BCRECON1.1440
ipos=ipos+u_field*p_levels BCRECON1.1441
BCRECON1.1442
! V BCRECON1.1443
write(6,*) ' V ' BCRECON1.1444
call minmax (data(ipos),u_field,p_levels,1,u_field) BCRECON1.1445
ipos=ipos+u_field*p_levels BCRECON1.1446
BCRECON1.1447
! THETAL BCRECON1.1448
write(6,*) ' THETAL' BCRECON1.1449
call minmax (data(ipos),p_field,p_levels,1,p_field) BCRECON1.1450
ipos=ipos+p_field*p_levels BCRECON1.1451
BCRECON1.1452
! QT BCRECON1.1453
write(6,*) ' QT' BCRECON1.1454
call minmax (data(ipos),p_field,q_levels,1,p_field) BCRECON1.1455
ipos=ipos+p_field*q_levels BCRECON1.1456
BCRECON1.1457
! TRACERS BCRECON1.1458
if(tr_vars.gt.0) then BCRECON1.1459
do itrace=1,tr_vars BCRECON1.1460
write(6,*) ' TRACER ',ITRACE BCRECON1.1461
call minmax (data(ipos),p_field,tr_levels,1,p_field) BCRECON1.1462
ipos=ipos+p_field*tr_levels BCRECON1.1463
enddo BCRECON1.1464
endif BCRECON1.1465
BCRECON1.1466
! QCF BCRECON1.1467
if (l_lspice) then BCRECON1.1468
write(6,*) ' QCF' BCRECON1.1469
call minmax (data(ipos),p_field,q_levels,1,p_field) BCRECON1.1470
endif BCRECON1.1471
BCRECON1.1472
return BCRECON1.1473
end BCRECON1.1474
BCRECON1.1475
!+ Subroutine MINMAX : Calculate max and min values in field BCRECON1.1476
! BCRECON1.1477
! Subroutine Interface : BCRECON1.1478
subroutine minmax(work,ifld,nlev,i1,i2) 7BCRECON1.1479
BCRECON1.1480
implicit none BCRECON1.1481
BCRECON1.1482
! Description : Get min and max values in boundary data. BCRECON1.1483
! BCRECON1.1484
! Method : For each level, calculate a max and min value and print. BCRECON1.1485
! BCRECON1.1486
! Current Code Owner : Dave Robinson, NWP BCRECON1.1487
! BCRECON1.1488
! History : BCRECON1.1489
! Version Date Comment BCRECON1.1490
! ------- ---- ------- BCRECON1.1491
! 4.4 10/10/97 Original Code BCRECON1.1492
! BCRECON1.1493
! Code Description : BCRECON1.1494
! Language : FORTRAN 77 + common extensions BCRECON1.1495
! This code is written to UMDP3 v6 programming standards. BCRECON1.1496
! BCRECON1.1497
! Declarations : BCRECON1.1498
! BCRECON1.1499
! Global Variables : BCRECON1.1500
! BCRECON1.1501
! Subroutine arguments BCRECON1.1502
! Scalar arguments with intent(in) : BCRECON1.1503
BCRECON1.1504
Integer ifld ! Field length BCRECON1.1505
Integer nlev ! No of levels BCRECON1.1506
Integer i1,i2 ! First and last point of field in WORK BCRECON1.1507
BCRECON1.1508
! Array arguments with intent(in) : BCRECON1.1509
BCRECON1.1510
Real work(ifld,nlev) ! Boundary Data BCRECON1.1511
BCRECON1.1512
! Scalar arguments with intent(InOut) : BCRECON1.1513
BCRECON1.1514
! Array arguments with intent(InOut) : BCRECON1.1515
BCRECON1.1516
! Scalar arguments with intent(out) : BCRECON1.1517
BCRECON1.1518
! Array arguments with intent(out) : BCRECON1.1519
BCRECON1.1520
! Local parameters : BCRECON1.1521
BCRECON1.1522
! Local scalars : BCRECON1.1523
BCRECON1.1524
Integer i,k ! Loop indices BCRECON1.1525
Integer iholdmin ! Position of minimum BCRECON1.1526
Integer iholdmax ! Position of maximum BCRECON1.1527
Real holdmin ! Minimum value BCRECON1.1528
Real holdmax ! Maximum value BCRECON1.1529
BCRECON1.1530
! Local dynamic arrays : BCRECON1.1531
BCRECON1.1532
! Function & Subroutine calls BCRECON1.1533
BCRECON1.1534
!- End of header BCRECON1.1535
BCRECON1.1536
do k=1,nlev BCRECON1.1537
BCRECON1.1538
holdmax=work(i1,k) BCRECON1.1539
iholdmax=i1 BCRECON1.1540
holdmin=work(i1,k) BCRECON1.1541
iholdmin=i1 BCRECON1.1542
BCRECON1.1543
do i=i1,i2 BCRECON1.1544
if (work(i,k).lt.holdmin) then BCRECON1.1545
holdmin=work(i,k) BCRECON1.1546
iholdmin=i BCRECON1.1547
endif BCRECON1.1548
if (work(i,k).gt.holdmax) then BCRECON1.1549
holdmax=work(i,k) BCRECON1.1550
iholdmax=i BCRECON1.1551
endif BCRECON1.1552
enddo ! loop over i (points) BCRECON1.1553
BCRECON1.1554
write(6,*) 'level',k,' max=',holdmax,' at ',iholdmax,' min=', BCRECON1.1555
* holdmin,' at ',iholdmin,' for (',i1,i2,')' BCRECON1.1556
BCRECON1.1557
enddo ! loop over k (levels) BCRECON1.1558
return BCRECON1.1559
end BCRECON1.1560
*ENDIF BCRECON1.1561