PROGRAM PPTOANC ,12PPTOANC1.21
PPTOANC1.22
implicit none PPTOANC1.23
! PPTOANC1.24
! Routine: pptoanc ------------------------------------------------- PPTOANC1.25
! PPTOANC1.26
! Description: PPTOANC1.27
! To create ancillary fields from pp fields. PPTOANC1.28
! pp fields are output in same order as they are input PPTOANC1.29
! PPTOANC1.30
! Method: PPTOANC1.31
! PPTOANC1.32
! PPTOANC1.33
! unit Description PPTOANC1.34
! ftin1=20 onwards INPUT pp files (unit #s provided by user) PPTOANC1.35
! ftin2=11 INPUT levels dataset (only used if compress=t PPTOANC1.36
! or flddepc=t) PPTOANC1.37
! ftout=10 OUTPUT ancillary file PPTOANC1.38
! PPTOANC1.39
! Use namelists to set: PPTOANC1.40
! PPTOANC1.41
! PPTOANC1.42
! sizes field_types,n_times,n_levels,n_pp_files, PPTOANC1.43
! n_freq_waves,n_dir_waves,stash_code,field_code, PPTOANC1.44
! nlevs_code,unit_no,len_intc,len_realc, PPTOANC1.45
! len1_levdepc,len2_levdepc,len1_rowdepc, PPTOANC1.46
! len2_rowdepc,len1_coldepc,len2_coldepc, PPTOANC1.47
! len1_flddepc,len2_flddepc,len_extcnst,rmdi_input PPTOANC1.48
! PPTOANC1.49
! logicals add_wrap_pts,periodic,single_time,ibm_to_cray, PPTOANC1.50
! compress,wave,levdepc,rowdepc,coldepc, PPTOANC1.51
! flddepc,extcnst,pack32,pphead,grid_of_tracer, PPTOANC1.52
! field_order PPTOANC1.53
! PPTOANC1.54
! first_vt fvhh,fvdd,fvmm,fvyy PPTOANC1.55
! (first validity time) PPTOANC1.56
! PPTOANC1.57
! last_vt lvhh,lvdd,lvmm,lvyy PPTOANC1.58
! (last validity time) PPTOANC1.59
! PPTOANC1.60
! interval year360,ivhh,ivdd,ivmm,ivyy PPTOANC1.61
! (time interval between validity times) PPTOANC1.62
! PPTOANC1.63
! header_data fixhd, int_const,real_const,lev_dep_consts, PPTOANC1.64
! row_dep_consts,col_dep_consts,extra_const, PPTOANC1.65
! ifld_int, item_int, ival_int, PPTOANC1.66
! ifld_real, item_real, rval_real PPTOANC1.67
! PPTOANC1.68
! The last 6 variables are arrays allowing up to n= len_look_user PPTOANC1.69
! changes to the lookup tables. All arrays are initiated as missing PPTOANC1.70
! data. Changes are made in the order from n=1 to len_look_user. If PPTOANC1.71
! ifld_int(n) or ifld_real(n) is not a missing data value, changes PPTOANC1.72
! are made to the integer or real lookup tables. PPTOANC1.73
! PPTOANC1.74
! for integer parts of lookup tables PPTOANC1.75
! ifld_int(n) field number to change PPTOANC1.76
! 0 => all lookup tables PPTOANC1.77
! item_int(n) item number to change PPTOANC1.78
! ival_int(n) integer value to use PPTOANC1.79
! PPTOANC1.80
! for real parts of lookup tables PPTOANC1.81
! ifld_real(n) field number to change PPTOANC1.82
! 0 => all lookup tables PPTOANC1.83
! item_real(n) item number to change PPTOANC1.84
! rval_real(n) real value to use PPTOANC1.85
! PPTOANC1.86
! The following elements are particularly worth checking PPTOANC1.87
! fixhd(4) grid type code (global is default) PPTOANC1.88
! fixhd(8) 360 day calendar is default PPTOANC1.89
! fixhd(12) UM version number PPTOANC1.90
! PPTOANC1.91
! fixhd and lookup for dates of validity PPTOANC1.92
! PPTOANC1.93
! The stash_code and field_code in the namelist sizes must be in the PPTOANC1.94
! same order as they are in the input pp fields PPTOANC1.95
! PPTOANC1.96
! Do not put field types requiring different compression indices PPTOANC1.97
! in one ancillary file. PPTOANC1.98
! PPTOANC1.99
! Current Code Owners: D Robinson / I Edmond PPTOANC1.100
! PPTOANC1.101
! History: PPTOANC1.102
! Author: Sue Nightingale PPTOANC1.103
! PPTOANC1.104
! MJB 16/6/94 CLL comments line added PPTOANC1.105
! version 3.2 RMDI s output; user can change PPTOANC1.106
! RMDI between input pp file and ouput PPTOANC1.107
! data written out by WRITFLDS PPTOANC1.108
! User can choose Cray 32-bit output PPTOANC1.109
! tracer_grid no longer dependent on user input PPTOANC1.110
! multi-level ancillary fields can be created; these PPTOANC1.111
! may be packed using compression indices PPTOANC1.112
! from a model dump PPTOANC1.113
! code will read pp fields with extra data PPTOANC1.114
! code is valid at version 3.3 of UM PPTOANC1.115
! MJB 19/7/94 user can modify lookup tables through the namelist PPTOANC1.116
! header_data PPTOANC1.117
! MJB 22/7/94 Input pp fields can be in one or more files. PPTOANC1.118
! Code to read past extra-data made more robust. PPTOANC1.119
! ancillary files with the same field code and PPTOANC1.120
! different stash codes can now be formed. PPTOANC1.121
! PPTOANC1.122
! MJB 18/8/94 LOOKUP(22,n) set to 2 (current header version) PPTOANC1.123
! PPTOANC1.124
! DR 07/9/94 Enable level dependent constants array to be set PPTOANC1.125
! up. New namelist variable LEVDEPC. PPTOANC1.126
! PPTOANC1.127
! DR 15/11/94 New FIRST_VT and LAST_VT namelists. Modify PPTOANC1.128
! INTERVAL namelist. PPTOANC1.129
! PPTOANC1.130
! MH xx/03/96 modified to allow creation of wave model dump PPTOANC1.131
! PPTOANC1.132
! MJB 09/09/96 Enable number of levels of data to depend on the PPTOANC1.133
! field code PPTOANC1.134
! PPTOANC1.135
! CGJ 21/01/97 Altered format of the code and enabled an ocean dump PPTOANC1.136
! to be created from only a levels dataset. PPTOANC1.137
! PPTOANC1.138
! History: PPTOANC1.139
! Version Date Comment PPTOANC1.140
! ------- ---- ------- PPTOANC1.141
! 4.4 14/8/97 Code consolidated into version 4.4 of UM system IE PPTOANC1.142
! 4.5 03/06/98 Increase max_len1_rowdepc and max_len1_coldepc UDR3F405.199
! to meet new ocean requirements. Correct rewinding UDR3F405.200
! of PP files. Copy pp_int(14). Read in env var UDR3F405.201
! UM_SECTOR_SIZE. D. Robinson. UDR3F405.202
! 4.5 03/09/98 Strip out ZPDATE routines and use new Y2K routines GKW1F405.1
! in deck ZPDATE1. D. Robinson. GKW1F405.2
! PPTOANC1.143
! Code Description: PPTOANC1.144
! Language: FORTRAN 77 + common extensions. PPTOANC1.145
! This code is written to UMDP3 v6 programming standards. PPTOANC1.146
! PPTOANC1.147
! Declarations: PPTOANC1.148
! These are of the form:- PPTOANC1.149
! INTEGER ExampleVariable !Description of variable PPTOANC1.150
! PPTOANC1.151
! Global variables (*CALLed COMDECKs etc...): PPTOANC1.152
*CALL CSUBMODL 
PPTOANC1.153
*CALL CLOOKADD PPTOANC1.154
*CALL C_MDI PPTOANC1.155
*CALL CNTL_IO UDR3F405.203
PPTOANC1.156
! Routine arguments PPTOANC1.157
! Scalar arguments PPTOANC1.158
PPTOANC1.159
integer n_stash_codes , ! counter for number of stash codes PPTOANC1.160
& n_unit_no , ! counter for number of unit numbers PPTOANC1.161
& len2_lookup_max , ! 2nd dimension for lookup array PPTOANC1.162
& ! in ancfld(maximum) PPTOANC1.163
& cols_nowrap , ! no. of columns east-west without PPTOANC1.164
& ! wrap_points PPTOANC1.165
& n,i , ! loop counter PPTOANC1.166
& icode , ! error exit condition code PPTOANC1.167
& ppxRecs PPTOANC1.168
PPTOANC1.169
! Define variables from SIZES namelist PPTOANC1.170
PPTOANC1.171
integer field_types , ! number of field types in I/O files PPTOANC1.172
& n_times , ! number of time periods in I/O files PPTOANC1.173
& nlevels , ! number of levels (default = 1) PPTOANC1.174
& n_pp_files , ! number of input pp files PPTOANC1.175
& n_freq_waves , ! number of wave frequencies PPTOANC1.176
& n_dir_waves , ! number of wave directions PPTOANC1.177
& len_intc , ! dimension for integer constants PPTOANC1.178
& len_realc , ! dimension for real constants PPTOANC1.179
& len_extra , ! dimension for extra data PPTOANC1.180
& len1_levdepc , ! dimension for levdepc array PPTOANC1.181
& len2_levdepc , ! 2nd dimension for levdepc array PPTOANC1.182
& len1_rowdepc , ! dimension for rowdepc array PPTOANC1.183
& len2_rowdepc , ! 2nd dimension for rowdepc array PPTOANC1.184
& len1_coldepc , ! dimension for coldepc array PPTOANC1.185
& len2_coldepc , ! 2nd dimension for coldepc array PPTOANC1.186
& len1_flddepc , ! dimension for flddepc array PPTOANC1.187
& len2_flddepc , ! 2nd dimension for flddepc array PPTOANC1.188
& len_extcnst ! dimension for extcnst array PPTOANC1.189
PPTOANC1.190
real rmdi_input ! real missing data indicator PPTOANC1.191
! in input pp field PPTOANC1.192
PPTOANC1.193
! Define variables from LOGICALS namelist PPTOANC1.194
PPTOANC1.195
logical add_wrap_pts , ! T => adds wrapping columns PPTOANC1.196
! e.g. for global grid PPTOANC1.197
& periodic , ! T => periodic in time PPTOANC1.198
! e.g. climate field PPTOANC1.199
& single_time , ! T => all fields input valid at one time PPTOANC1.200
& ibm_to_cray , ! T => input pp data is in IBM number PPTOANC1.201
! format and needs to be converted to PPTOANC1.202
! run on the Cray. PPTOANC1.203
! (Only use if running on Cray) PPTOANC1.204
& compress , ! T => fields are packed into ancillary PPTOANC1.205
! field compressed field indices are PPTOANC1.206
! calculated PPTOANC1.207
& wave , ! T => a wave dump is to be created PPTOANC1.208
& levdepc , ! T => if level dependent constants array PPTOANC1.209
! required PPTOANC1.210
& rowdepc , ! T => if row dependant constants are PPTOANC1.211
! required PPTOANC1.212
& coldepc , ! T => if column dependant constants are PPTOANC1.213
! required PPTOANC1.214
& flddepc , ! T => if fields of constants are PPTOANC1.215
! required PPTOANC1.216
& extcnst , ! T => if fields of constants are PPTOANC1.217
! required PPTOANC1.218
PPTOANC1.219
& pack32 , ! T => use 32 bit Cray numbers PPTOANC1.220
& pphead , ! T => print out pp headers read in PPTOANC1.221
PPTOANC1.222
& field_order , ! T => input pp fields ordered by time. PPTOANC1.223
! i.e. different months in input PPTOANC1.224
! files, same fields in all files PPTOANC1.225
! F => inout pp fields ordered by fields. PPTOANC1.226
! i.e. different fields in input PPTOANC1.227
! files, all months in all files PPTOANC1.228
PPTOANC1.229
& lwfio ! T => set the LBEGIN and LBNREC fields PPTOANC1.230
! in the LOOKUP Headers for VN 16 PPTOANC1.231
! Type Dumpfiles. PPTOANC1.232
! F => Old dumpfiles PPTOANC1.233
PPTOANC1.234
character*80 namelst PPTOANC1.235
character*80 cmessage PPTOANC1.236
Character*8 c_um_sector_size ! Char variable to read env var UDR3F405.204
UDR3F405.205
PPTOANC1.237
PPTOANC1.238
! Parameters: PPTOANC1.239
integer ftin2 ! input unit for mask file used PPTOANC1.240
parameter (ftin2=11) ! for level dependent consts and PPTOANC1.241
! compression indices. PPTOANC1.242
! Only used when compress is T PPTOANC1.243
integer ftout PPTOANC1.244
parameter (ftout=10) ! unit number for output ancillary PPTOANC1.245
! file PPTOANC1.246
integer nolevsmax PPTOANC1.247
parameter (nolevsmax=200) ! max number of levels; dimensions PPTOANC1.248
! fldsizelev array PPTOANC1.249
integer number_of_codes PPTOANC1.250
parameter (number_of_codes=100)! max number of stash/field codes PPTOANC1.251
PPTOANC1.252
integer max_n_pp_files PPTOANC1.253
parameter (max_n_pp_files=30) ! max number of input pp files PPTOANC1.254
PPTOANC1.255
integer max_ncol ! maximum no. of cols in field PPTOANC1.256
parameter (max_ncol = 400) PPTOANC1.257
PPTOANC1.258
integer max_nrow ! maximum no. of rows in field PPTOANC1.259
parameter (max_nrow = 800) PPTOANC1.260
PPTOANC1.261
! Array arguments: PPTOANC1.262
PPTOANC1.263
integer len_cfi(3) , ! lengths of compressed field indices PPTOANC1.264
& fldsizelev(nolevsmax) ! size of packed field PPTOANC1.265
! on each level PPTOANC1.266
PPTOANC1.267
logical grid_of_tracer(number_of_codes) ! T => fields are on a PPTOANC1.268
! tracer grid PPTOANC1.269
PPTOANC1.270
! Define variables from SIZES namelist PPTOANC1.271
PPTOANC1.272
integer stash_code(number_of_codes),! array of stash codes PPTOANC1.273
& field_code(number_of_codes),! array of field codes PPTOANC1.274
& nlevs_code(number_of_codes),! array of levels depending PPTOANC1.275
! on field code PPTOANC1.276
& unit_no(number_of_codes) ! array of unit numbers for PPTOANC1.277
! input PPTOANC1.278
PPTOANC1.279
! Function & Subroutine calls: PPTOANC1.280
integer FIND_NAMELIST PPTOANC1.281
PPTOANC1.282
!- End of header PPTOANC1.283
PPTOANC1.284
namelist /sizes/ field_types,n_times,nlevels,n_pp_files, PPTOANC1.285
# n_freq_waves,n_dir_waves,stash_code,field_code,nlevs_code, PPTOANC1.286
# unit_no,len_intc,len_realc,len1_levdepc,len2_levdepc, PPTOANC1.287
# len1_rowdepc,len2_rowdepc,len1_coldepc,len2_coldepc, PPTOANC1.288
# len1_flddepc,len2_flddepc,len_extcnst,rmdi_input PPTOANC1.289
PPTOANC1.290
namelist /logicals/ add_wrap_pts,periodic,single_time, PPTOANC1.291
# ibm_to_cray,compress,wave,levdepc,rowdepc,coldepc,flddepc, PPTOANC1.292
# extcnst,pack32,pphead,grid_of_tracer,field_order,lwfio PPTOANC1.293
PPTOANC1.294
PPTOANC1.295
CL 1 Set values PPTOANC1.296
PPTOANC1.297
CL 1.0 Set default values for SIZES NAMELIST PPTOANC1.298
PPTOANC1.299
PPTOANC1.300
field_types = 2 PPTOANC1.301
n_times = 12 PPTOANC1.302
nlevels = 1 PPTOANC1.303
n_pp_files = 1 PPTOANC1.304
n_freq_waves = 1 PPTOANC1.305
n_dir_waves = 1 PPTOANC1.306
len_intc = 40 PPTOANC1.307
len_realc = 40 PPTOANC1.308
len1_levdepc = 1 PPTOANC1.309
len2_levdepc = 1 PPTOANC1.310
len1_rowdepc = 1 PPTOANC1.311
len2_rowdepc = 1 PPTOANC1.312
len1_coldepc = 1 PPTOANC1.313
len2_coldepc = 1 PPTOANC1.314
len1_flddepc = 1 PPTOANC1.315
len2_flddepc = 1 PPTOANC1.316
len_extcnst = 1 PPTOANC1.317
PPTOANC1.318
rmdi_input = rmdi PPTOANC1.319
PPTOANC1.320
CL 1.1 Initialise arrays in SIZES NAMELIST PPTOANC1.321
PPTOANC1.322
do n=1,number_of_codes PPTOANC1.323
field_code(n)=-99 PPTOANC1.324
stash_code(n)=-99 PPTOANC1.325
nlevs_code(n)=1 PPTOANC1.326
unit_no(n)=-99 PPTOANC1.327
enddo PPTOANC1.328
PPTOANC1.329
CL 1.2 Open UNIT05 containing namelists and read in SIZES NAMELIST PPTOANC1.330
PPTOANC1.331
call get_file(5,namelst,80,icode) PPTOANC1.332
OPEN(UNIT=5,FILE=NAMELST,DELIM='APOSTROPHE') PXNAMLST.7
PPTOANC1.334
rewind(5) PPTOANC1.335
I=FIND_NAMELIST(5,"SIZES") PPTOANC1.336
PPTOANC1.337
If(I.eq.0)then PPTOANC1.338
read(5,SIZES) PPTOANC1.339
Else PPTOANC1.340
write(6,*)'Cannot find namelist SIZES' PPTOANC1.341
End if PPTOANC1.342
PPTOANC1.343
write (6,*) ' ' PPTOANC1.344
write (6,*) 'SIZES namelist is set up as follows:-' PPTOANC1.345
write (6,*) ' ' PPTOANC1.346
write (6,sizes) PPTOANC1.347
PPTOANC1.348
CL 1.3 Check that n_pp_files is not greater than max_n_pp_files PPTOANC1.349
PPTOANC1.350
if (n_pp_files.le.0 .or. n_pp_files.gt.max_n_pp_files) then PPTOANC1.351
write (6,*) ' ' PPTOANC1.352
write (6,*) ' N_PP_FILES must in range 1-',MAX_N_PP_FILES PPTOANC1.353
write (6,*) ' N_PP_FILES must in range 1-',number_of_codes PPTOANC1.354
write (6,*) ' Resubmit job with new value for N_PP_FILES' PPTOANC1.355
go to 9999 ! Return PPTOANC1.356
endif PPTOANC1.357
PPTOANC1.358
CL 1.4 Check that n_times and number of field_types is not greater PPTOANC1.359
CL than number_of_codes PPTOANC1.360
PPTOANC1.361
if (n_times .gt. number_of_codes .or. PPTOANC1.362
& field_types .gt. number_of_codes ) then PPTOANC1.363
write (6,*) ' ' PPTOANC1.364
write (6,*) ' ** WARNING ** WARNING ** ' PPTOANC1.365
write (6,*) ' N_TIMES = ',n_times,' or FIELD_TYPES = ', PPTOANC1.366
& field_types,' greater than NUMBER_OF_CODES = ',number_of_codes PPTOANC1.367
write (6,*) ' Dimension of UNIT_NO may be too small if used.' PPTOANC1.368
endif PPTOANC1.369
PPTOANC1.370
CL 1.5 Count the number of stash codes and check they are not PPTOANC1.371
CL greater than number of field_types PPTOANC1.372
PPTOANC1.373
n_stash_codes = 0 PPTOANC1.374
do n=1,number_of_codes PPTOANC1.375
if (stash_code(n).ge.0) then PPTOANC1.376
n_stash_codes = n_stash_codes + 1 PPTOANC1.377
endif PPTOANC1.378
enddo PPTOANC1.379
PPTOANC1.380
if (n_stash_codes.ne.field_types) then PPTOANC1.381
write (6,*) ' ' PPTOANC1.382
write (6,*) ' Wrong number of stash codes provided.' PPTOANC1.383
write (6,*) n_stash_codes,' stash codes in namelist.' PPTOANC1.384
write (6,*) field_types ,' stash codes expected.' PPTOANC1.385
write (6,*) ' Rerun with correct no of stash codes' PPTOANC1.386
go to 9999 ! Return PPTOANC1.387
else PPTOANC1.388
write (6,*) ' ' PPTOANC1.389
write (6,*) n_stash_codes,' stash codes in SIZES namelist.' PPTOANC1.390
endif PPTOANC1.391
PPTOANC1.392
if (nlevels .gt. nolevsmax) then PPTOANC1.393
write(6,*) 'parameter nolevsmax is smaller than nlevels' PPTOANC1.394
write(6,*) 'increase nolevsmax in program create' PPTOANC1.395
go to 9999 ! Jump out PPTOANC1.396
end if PPTOANC1.397
PPTOANC1.398
if (rmdi_input .eq. rmdi) then PPTOANC1.399
write(6,*) 'rmdi_input should equal rmdi in input pp field' PPTOANC1.400
write(6,*) 'WARNING !!! ' PPTOANC1.401
write(6,*) 'if not, RESUBMIT with the correct rmdi_input in PPTOANC1.402
& SIZES namelist.' PPTOANC1.403
end if PPTOANC1.404
PPTOANC1.405
CL PPTOANC1.406
CL 1.6 Set default values for LOGICALS NAMELIST PPTOANC1.407
CL PPTOANC1.408
add_wrap_pts = .false. PPTOANC1.409
periodic = .false. PPTOANC1.410
single_time = .false. PPTOANC1.411
ibm_to_cray = .false. PPTOANC1.412
compress = .false. PPTOANC1.413
wave = .false. PPTOANC1.414
levdepc = .false. PPTOANC1.415
rowdepc = .false. PPTOANC1.416
coldepc = .false. PPTOANC1.417
flddepc = .false. PPTOANC1.418
extcnst = .false. PPTOANC1.419
pack32 = .false. PPTOANC1.420
pphead = .false. PPTOANC1.421
field_order = .true. PPTOANC1.422
lwfio = .true. PPTOANC1.423
PPTOANC1.424
CL 1.7 Initialise array in LOGICAL NAMELIST PPTOANC1.425
PPTOANC1.426
do n = 1, number_of_codes PPTOANC1.427
grid_of_tracer(n)=.true. PPTOANC1.428
enddo PPTOANC1.429
PPTOANC1.430
CL 1.8 Read in the LOGICALS NAMELIST PPTOANC1.431
PPTOANC1.432
rewind(5) PPTOANC1.433
I=FIND_NAMELIST(5,"LOGICALS") PPTOANC1.434
PPTOANC1.435
If(I.eq.0)then PPTOANC1.436
read(5,LOGICALS) PPTOANC1.437
Else PPTOANC1.438
write(6,*)'Cannot find namelist LOGICALS' PPTOANC1.439
End if PPTOANC1.440
PPTOANC1.441
write (6,*) ' ' PPTOANC1.442
write (6,*) 'LOGICALS namelist is set up as follows:-' PPTOANC1.443
write (6,*) ' ' PPTOANC1.444
write (6,logicals) PPTOANC1.445
PPTOANC1.446
CL 1.9 Count number of unit numbers needed which depends on field_order, PPTOANC1.447
CL n_times and field_types PPTOANC1.448
PPTOANC1.449
n_unit_no = 0 PPTOANC1.450
do n=1,number_of_codes PPTOANC1.451
if (unit_no(n).gt.0) then PPTOANC1.452
n_unit_no = n_unit_no + 1 PPTOANC1.453
endif PPTOANC1.454
enddo PPTOANC1.455
PPTOANC1.456
PPTOANC1.457
if (n_unit_no.gt.0) then PPTOANC1.458
do n=1,n_unit_no PPTOANC1.477
if (unit_no(n).lt.20 .or. unit_no(n).gt.19+n_pp_files) then PPTOANC1.478
write (6,*) ' ' PPTOANC1.479
write (6,*) ' Unit no out of range in UNIT_NO :',unit_no(n) PPTOANC1.480
write (6,*) ' Range is 20-',19+n_pp_files PPTOANC1.481
write (6,*) ' Rerun with correct unit numbers' PPTOANC1.482
go to 9999 ! Return PPTOANC1.483
endif PPTOANC1.484
enddo PPTOANC1.485
else ! n_unit_no PPTOANC1.486
do n=1,max_n_pp_files PPTOANC1.487
unit_no(n)=19+n PPTOANC1.488
enddo PPTOANC1.489
endif PPTOANC1.490
PPTOANC1.491
CL 1.10 Get the current sector size for disk I/O UDR3F405.206
UDR3F405.207
CALL FORT_GET_ENV('UM_SECTOR_SIZE',14,c_um_sector_size,8,icode) UDR3F405.208
IF (icode .NE. 0) THEN UDR3F405.209
WRITE(6,*) ' Warning : Environment variable UM_SECTOR_SIZE', UDR3F405.210
& ' has not been set.' UDR3F405.211
WRITE(6,*) 'Setting um_sector_size to 2048' UDR3F405.212
um_sector_size=2048 UDR3F405.213
ELSE UDR3F405.214
READ(c_um_sector_size,'(I4)') um_sector_size UDR3F405.215
write (6,*) ' ' UDR3F405.216
write (6,*) ' UM_SECTOR_SIZE is set to ',um_sector_size UDR3F405.217
write (6,*) ' ' UDR3F405.218
ENDIF UDR3F405.219
UDR3F405.220
CL 2 Set dimensions PPTOANC1.492
PPTOANC1.493
CL 2.0 If data are to be compressed calculate the lengths of compression PPTOANC1.494
CL indices and number of points in field on each level using the PPTOANC1.495
CL levels dataset PPTOANC1.496
PPTOANC1.497
if (add_wrap_pts) then PPTOANC1.498
cols_nowrap = len1_coldepc-2 PPTOANC1.499
else PPTOANC1.500
cols_nowrap = len1_coldepc PPTOANC1.501
endif PPTOANC1.502
PPTOANC1.503
if (compress .and. .not. wave) then PPTOANC1.504
PPTOANC1.505
call calc_len_cfi(ftin2,cols_nowrap,len1_rowdepc, PPTOANC1.506
& nlevels,len_cfi,fldsizelev,ibm_to_cray,add_wrap_pts, PPTOANC1.507
& icode) PPTOANC1.508
PPTOANC1.509
if (icode .ne. 0) then PPTOANC1.510
go to 9999 ! jump out PPTOANC1.511
end if PPTOANC1.512
PPTOANC1.513
else ! .not. compress PPTOANC1.514
PPTOANC1.515
len_cfi(1) = 1 PPTOANC1.516
len_cfi(2) = 1 PPTOANC1.517
len_cfi(3) = 1 PPTOANC1.518
PPTOANC1.519
end if ! compress PPTOANC1.520
PPTOANC1.521
CL PPTOANC1.522
CL 2.1 Calculate len2_lookup_max which depends on wave dimensions PPTOANC1.523
CL PPTOANC1.524
icode = 0 PPTOANC1.525
PPTOANC1.526
if (wave) then PPTOANC1.527
len2_lookup_max = field_types*n_times*nlevels PPTOANC1.528
& + (n_freq_waves*n_dir_waves -1)*n_times PPTOANC1.529
PPTOANC1.530
else PPTOANC1.531
len2_lookup_max = field_types*n_times*nlevels PPTOANC1.532
end if PPTOANC1.533
PPTOANC1.534
print*,'len2_lookup_max set to ',len2_lookup_max PPTOANC1.535
print*,' ' PPTOANC1.536
CL PPTOANC1.537
CL 3 Read STASHmaster files PPTOANC1.538
PPTOANC1.539
CL 3.1 Initialise N_INTERNAL_MODEL/INTERNAL_MODEL_INDEX PPTOANC1.540
PPTOANC1.541
N_INTERNAL_MODEL=4 PPTOANC1.542
INTERNAL_MODEL_INDEX(1)=1 ! Atmos PPTOANC1.543
INTERNAL_MODEL_INDEX(2)=2 ! Ocean PPTOANC1.544
INTERNAL_MODEL_INDEX(3)=3 ! Slab PPTOANC1.545
INTERNAL_MODEL_INDEX(4)=4 ! Wave PPTOANC1.546
PPTOANC1.547
CL 3.2 Determine ppxRecs from Stashmaster files PPTOANC1.548
PPTOANC1.549
ppxRecs=1 PPTOANC1.550
CALL HDPPXRF(22,'STASHmaster_A',ppxRecs,ICODE,CMESSAGE) PPTOANC1.551
PPTOANC1.552
CL 3.3 Read Ocean file and obtain number of records PPTOANC1.553
PPTOANC1.554
CALL HDPPXRF(22,'STASHmaster_O',ppxRecs,ICODE,CMESSAGE) PPTOANC1.555
PPTOANC1.556
CL 3.4 Read Slab file and obtain number of records PPTOANC1.557
PPTOANC1.558
CALL HDPPXRF(22,'STASHmaster_S',ppxRecs,ICODE,CMESSAGE) PPTOANC1.559
PPTOANC1.560
CL 3.5 Read Wave file and obtain number of records PPTOANC1.561
PPTOANC1.562
CALL HDPPXRF(22,'STASHmaster_W',ppxRecs,ICODE,CMESSAGE) PPTOANC1.563
PPTOANC1.564
CL 4 Call main subroutine PPTOANC1.565
PPTOANC1.566
call anc_fld(ftin2,ftout,nolevsmax,number_of_codes, PPTOANC1.567
# max_n_pp_files,len_cfi,fldsizelev, PPTOANC1.568
# field_types,n_times,nlevels,n_pp_files,stash_code,field_code, PPTOANC1.569
# nlevs_code,unit_no,n_freq_waves,n_dir_waves,len_intc,len_realc, PPTOANC1.570
# len_extra,len1_levdepc,len2_levdepc,len1_rowdepc,len2_rowdepc, PPTOANC1.571
# len1_coldepc,len2_coldepc,len1_flddepc,len2_flddepc, PPTOANC1.572
# len_extcnst,rmdi_input, PPTOANC1.573
# add_wrap_pts,periodic,single_time,ibm_to_cray,compress,wave, PPTOANC1.574
# levdepc,rowdepc,coldepc,flddepc,extcnst,pack32,pphead, PPTOANC1.575
# grid_of_tracer,field_order,lwfio, PPTOANC1.576
! # len2_lookup_max,cols_nowrap,icode) PPTOANC1.577
# len2_lookup_max,cols_nowrap,ppxRecs,icode) PPTOANC1.578
PPTOANC1.579
if (icode .gt. 0) then PPTOANC1.580
go to 9999 ! Jump out PPTOANC1.581
end if PPTOANC1.582
PPTOANC1.583
CL 5 Tidy up at end of program PPTOANC1.584
PPTOANC1.585
CL 5.1 Close ancillary file PPTOANC1.586
PPTOANC1.587
call file_close (ftout,'ANCFILE',7,1,0,icode) PPTOANC1.588
if (icode. gt. 0) then PPTOANC1.589
write (6,*) ' Problem with FILE_CLOSE for unit no ',ftout PPTOANC1.590
go to 9999 ! Jump out PPTOANC1.591
end if PPTOANC1.592
PPTOANC1.593
C =========================================================== PPTOANC1.594
CL 5.2 NORMAL COMPLETION. PPTOANC1.595
C =========================================================== PPTOANC1.596
write (6,*) ' ' PPTOANC1.597
write (6,*) 'Program completed normally' PPTOANC1.598
write (6,*) 'Return code = ',icode PPTOANC1.599
write (6,*) ' ' PPTOANC1.600
stop PPTOANC1.601
PPTOANC1.602
C =========================================================== PPTOANC1.603
CL 5.3 ABNORMAL COMPLETION. PPTOANC1.604
C =========================================================== PPTOANC1.605
9999 continue PPTOANC1.606
write (6,*) 'PPTOANC Program' PPTOANC1.607
write (6,*) 'Return code has been set in program' PPTOANC1.608
write (6,*) 'Return code = ',icode PPTOANC1.609
write (6,*) ' ' PPTOANC1.610
write (6,*) 'Program aborted' PPTOANC1.611
call abort PPTOANC1.612
PPTOANC1.613
end PPTOANC1.614
! PPTOANC1.615
! Subroutine interface: PPTOANC1.616
subroutine anc_fld(ftin2,ftout,nolevsmax,number_of_codes, 1,22PPTOANC1.617
& max_n_pp_files,len_cfi,fldsizelev, PPTOANC1.618
& field_types,n_times,nlevels,n_pp_files,stash_code,field_code, PPTOANC1.619
& nlevs_code,unit_no,n_freq_waves,n_dir_waves,len_intc,len_realc, PPTOANC1.620
& len_extra,len1_levdepc,len2_levdepc,len1_rowdepc,len2_rowdepc, PPTOANC1.621
& len1_coldepc,len2_coldepc,len1_flddepc,len2_flddepc, PPTOANC1.622
& len_extcnst,rmdi_input, PPTOANC1.623
& add_wrap_pts,periodic,single_time,ibm_to_cray,compress,wave, PPTOANC1.624
& levdepc,rowdepc,coldepc,flddepc,extcnst,pack32,pphead, PPTOANC1.625
& grid_of_tracer,field_order,lwfio, PPTOANC1.626
& len2_lookup_max,cols_nowrap,ppxRecs,icode) PPTOANC1.627
PPTOANC1.628
implicit none PPTOANC1.629
! PPTOANC1.630
! Description: PPTOANC1.631
! Main subroutine. Creates the ancillary/dump header, PPTOANC1.632
! lookup tables and writes the header using WRITHEAD. PPTOANC1.633
! Calls dataw which writes the data out PPTOANC1.634
! PPTOANC1.635
! PPTOANC1.636
! PPTOANC1.637
! Method: PPTOANC1.638
! PPTOANC1.639
! Current Code Owner: D Robinson / I Edmond PPTOANC1.640
! PPTOANC1.641
! History: PPTOANC1.642
! Version Date Comment PPTOANC1.643
! ------- ---- ------- PPTOANC1.644
! 16/06/94 Original code. Dave Robinson PPTOANC1.645
! 4.4 14/8/97 Consolidated in UM Ian Edmond PPTOANC1.646
! PPTOANC1.647
! Code Description: PPTOANC1.648
! Language: FORTRAN 77 + common extensions. PPTOANC1.649
! This code is written to UMDP3 v6 programming standards. PPTOANC1.650
! PPTOANC1.651
! Declarations: PPTOANC1.652
! These are of the form:- PPTOANC1.653
! INTEGER ExampleVariable !Description of variable PPTOANC1.654
! PPTOANC1.655
! 1.0 Global variables (*CALLed COMDECKs etc...): PPTOANC1.656
*CALL CSUBMODL PPTOANC1.657
*CALL CPPXREF PPTOANC1.658
*CALL PPXLOOK PPTOANC1.659
*CALL CLOOKADD PPTOANC1.660
*CALL C_MDI PPTOANC1.661
PPTOANC1.662
! Subroutine arguments PPTOANC1.663
! Scalar arguments with intent(in): PPTOANC1.664
PPTOANC1.665
integer ftin2 ! input unit for mask file used PPTOANC1.666
! for fields consts and PPTOANC1.667
! compression indices. PPTOANC1.668
integer ftout ! unit number for output ancillary PPTOANC1.669
! file PPTOANC1.670
PPTOANC1.671
integer nolevsmax ! max number of levels; dimensions PPTOANC1.672
! fldsizelev array PPTOANC1.673
integer number_of_codes ! max number of stash/field codes PPTOANC1.674
integer max_n_pp_files ! max number of input pp files PPTOANC1.675
PPTOANC1.676
PPTOANC1.677
PPTOANC1.678
integer field_types ! number of field types in I/O files PPTOANC1.679
integer n_times ! number of time periods in I/O files PPTOANC1.680
integer nlevels ! number of levels (default = 1) PPTOANC1.681
integer n_pp_files ! number of input pp files PPTOANC1.682
PPTOANC1.683
PPTOANC1.684
integer n_freq_waves ! number of wave frequencies PPTOANC1.685
integer n_dir_waves ! number of wave directions PPTOANC1.686
PPTOANC1.687
integer len_intc ! Actual length of integer constants array PPTOANC1.688
integer len_realc ! Actual length of real constants array PPTOANC1.689
PPTOANC1.690
integer len_extra ! length of extra data (minimum value = 0) PPTOANC1.691
PPTOANC1.692
integer len1_levdepc ! Actual 1st dimension of lev_dep_consts PPTOANC1.693
integer len2_levdepc ! Actual 2nd dimension of lev_dep_consts PPTOANC1.694
PPTOANC1.695
integer len1_rowdepc ! Actual 1st dimension of row_dep_consts PPTOANC1.696
integer len2_rowdepc ! Actual 2nd dimension of row_dep_consts PPTOANC1.697
PPTOANC1.698
integer len1_coldepc ! Actual 1st dimension of col_dep_consts PPTOANC1.699
integer len2_coldepc ! Actual 2nd dimension of col_dep_consts PPTOANC1.700
PPTOANC1.701
integer len1_flddepc ! Actual 1st dimension of fields_const PPTOANC1.702
integer len2_flddepc ! Actual 2nd dimension of fields_const PPTOANC1.703
PPTOANC1.704
integer len_extcnst ! Actual 1st dimension of fields_const PPTOANC1.705
PPTOANC1.706
integer len2_lookup_max ! maximum 2nd dimension of the lookup PPTOANC1.707
! table PPTOANC1.708
integer cols_nowrap ! no. of columns in field without wrap PPTOANC1.709
integer icode ! error code variable PPTOANC1.710
PPTOANC1.711
real rmdi_input ! real missing data indicator PPTOANC1.712
! in input pp field PPTOANC1.713
PPTOANC1.714
logical add_wrap_pts ! T => adds wrapping columns PPTOANC1.715
! e.g. for global grid PPTOANC1.716
logical periodic ! T => periodic in time PPTOANC1.717
! e.g. climate field PPTOANC1.718
logical single_time ! T => all fields input valid at one time PPTOANC1.719
logical ibm_to_cray ! T => input pp data is in IBM number PPTOANC1.720
! format and needs to be converted to PPTOANC1.721
! run on the Cray. PPTOANC1.722
! (Only use if running on Cray) PPTOANC1.723
logical compress ! T => fields are packed into ancillary PPTOANC1.724
! field compressed field indices are PPTOANC1.725
! calculated PPTOANC1.726
logical wave ! T => a wave dump is to be created PPTOANC1.727
logical levdepc ! T => if level dependent constants array PPTOANC1.728
! required PPTOANC1.729
logical rowdepc ! T => if row dependant constants are PPTOANC1.730
! required PPTOANC1.731
logical coldepc ! T => if column dependant constants are PPTOANC1.732
! required PPTOANC1.733
logical flddepc ! T => if fields of constants are PPTOANC1.734
! required PPTOANC1.735
logical extcnst ! T => if fields of constants are PPTOANC1.736
! required PPTOANC1.737
logical pack32 ! T => use 32 bit Cray numbers PPTOANC1.738
logical pphead ! T => print out pp headers read in PPTOANC1.739
PPTOANC1.740
PPTOANC1.741
logical field_order ! T => input pp fields ordered by time. PPTOANC1.742
! i.e. different months in input PPTOANC1.743
! files, same fields in all files PPTOANC1.744
! F => inout pp fields ordered by fields. PPTOANC1.745
! i.e. different fields in input PPTOANC1.746
! files, all months in all files PPTOANC1.747
logical lwfio ! T => set the LBEGIN and LBNREC fields PPTOANC1.748
! in the LOOKUP Headers for VN 16 PPTOANC1.749
! Type Dumpfiles. PPTOANC1.750
! F => Old dumpfiles PPTOANC1.751
PPTOANC1.752
PPTOANC1.753
! Array arguments with intent(in): PPTOANC1.754
PPTOANC1.755
integer len_cfi(3) ! lengths of compressed field indices PPTOANC1.756
integer fldsizelev(nolevsmax)! size of packed field on each level PPTOANC1.757
integer stash_code(number_of_codes) ! array of stash codes PPTOANC1.758
integer field_code(number_of_codes) ! array of field codes PPTOANC1.759
integer nlevs_code(number_of_codes) ! array of levels depending PPTOANC1.760
! on field code PPTOANC1.761
integer unit_no(number_of_codes) ! array of unit numbers for PPTOANC1.762
! input PPTOANC1.763
logical grid_of_tracer(number_of_codes) ! T => fields are on a PPTOANC1.764
! tracer grid PPTOANC1.765
PPTOANC1.766
PPTOANC1.767
! Local parameters: PPTOANC1.768
PPTOANC1.769
integer len_look_user ! No. of changes to the lookup table PPTOANC1.770
! made by the user PPTOANC1.771
integer len1_lookup ! 1st dimension of the lookup PPTOANC1.772
integer len1_lookup_all ! Dimension of the whole lookup array PPTOANC1.773
integer lfh ! length of the fixed length header PPTOANC1.774
PPTOANC1.775
integer max_len_intc ! Max dimension of integer constants PPTOANC1.776
integer max_len_realc ! Max dimension of real constants PPTOANC1.777
integer max_len1_levdepc ! Max 1st dimension of lev_dep_consts PPTOANC1.778
integer max_len2_levdepc ! Max 2nd dimension of lev_dep_consts PPTOANC1.779
integer max_len1_rowdepc ! Max 1st dimension of row_dep_consts PPTOANC1.780
integer max_len2_rowdepc ! Max 2nd dimension of row_dep_consts PPTOANC1.781
integer max_len1_coldepc ! Max 1st dimension of col_dep_consts PPTOANC1.782
integer max_len2_coldepc ! Max 2nd dimension of col_dep_consts PPTOANC1.783
integer max_len_extcnst ! Max dimension of extra_const PPTOANC1.784
PPTOANC1.785
integer len_dumphist ! Actual dimension of dumphist PPTOANC1.786
PPTOANC1.787
parameter (len_look_user = 12) PPTOANC1.788
parameter (len1_lookup = 45) PPTOANC1.789
parameter (len1_lookup_all = 64) PPTOANC1.790
parameter (lfh=256) PPTOANC1.791
PPTOANC1.792
parameter (max_len_intc=40) PPTOANC1.793
parameter (max_len_realc=40) PPTOANC1.794
parameter (max_len1_levdepc=100) PPTOANC1.795
parameter (max_len2_levdepc=5) PPTOANC1.796
parameter (max_len1_rowdepc=540) UDR3F405.221
parameter (max_len2_rowdepc=5) PPTOANC1.798
parameter (max_len1_coldepc=1082) UDR3F405.222
parameter (max_len2_coldepc=5) PPTOANC1.800
parameter (max_len_extcnst=500) PPTOANC1.801
PPTOANC1.802
parameter (len_dumphist=1) PPTOANC1.803
PPTOANC1.804
! Local Scalars PPTOANC1.805
PPTOANC1.806
PPTOANC1.807
integer ftin1 ! unit number for input pp fields PPTOANC1.808
PPTOANC1.809
integer len_data ! length of the data record PPTOANC1.810
integer start_block ! position of start for WRITHEAD PPTOANC1.811
PPTOANC1.812
integer n_sea_points ! number of sea points for wave dump PPTOANC1.813
PPTOANC1.814
integer rows ! no. of rows in input pp field PPTOANC1.815
integer columns ! no. of columns in input pp field PPTOANC1.816
PPTOANC1.817
integer i,j ! loop counters PPTOANC1.818
integer levn ! level number PPTOANC1.819
integer m,n ! loop counters PPTOANC1.820
integer np ! Number of points in pp field PPTOANC1.821
PPTOANC1.822
integer len2_lookup ! 2nd dimension of lookup table PPTOANC1.823
! total number of fields in output file PPTOANC1.824
integer len2_step ! calculation step for len2_lookup PPTOANC1.825
PPTOANC1.826
integer nlevs_this_code ! # of levels for this field code and PPTOANC1.827
! limit for do -loop over levels(waves) PPTOANC1.828
PPTOANC1.829
integer fieldn ! present field number PPTOANC1.830
integer fieldsize ! size of field when it is stored PPTOANC1.831
! in output data set PPTOANC1.832
integer runtot ! running total of start address PPTOANC1.833
! in data array of present field PPTOANC1.834
PPTOANC1.835
PPTOANC1.836
integer no_cmp ! total no. of compressed points in PPTOANC1.837
! compressed array PPTOANC1.838
integer ipos ! position counter PPTOANC1.839
PPTOANC1.840
integer irow_number PPTOANC1.841
PPTOANC1.842
integer PPTOANC1.843
& disk_address ! Current rounded disk address PPTOANC1.844
&,number_of_data_words_on_disk ! Number of data words on disk PPTOANC1.845
&,number_of_data_words_in_memory ! Number of Data Words in memory PPTOANC1.846
PPTOANC1.847
logical tracer_grid ! T => field is on a tracer grid PPTOANC1.848
! F =>field is on a velocity grid PPTOANC1.849
PPTOANC1.850
logical t_compress ! compress argument for DATA subroutine PPTOANC1.851
! used for wave dump LSmask set f whatever PPTOANC1.852
! compress is PPTOANC1.853
PPTOANC1.854
PPTOANC1.855
character*80 cmessage ! error message from WRITHEAD PPTOANC1.856
character*80 ancfile, levels PPTOANC1.857
PPTOANC1.858
! Local arrays dimensioned by parameters: PPTOANC1.859
PPTOANC1.860
! arrays to overwrite integer lookup tables PPTOANC1.861
PPTOANC1.862
integer ifld_int(len_look_user) ! int lookup fields to change PPTOANC1.863
integer item_int(len_look_user) ! item number to change PPTOANC1.864
integer ival_int(len_look_user) ! integer value to use PPTOANC1.865
PPTOANC1.866
! arrays to overwrite real lookup tables PPTOANC1.867
PPTOANC1.868
integer ifld_real(len_look_user) ! lookup fields to change PPTOANC1.869
integer item_real(len_look_user) ! item number to change PPTOANC1.870
real rval_real(len_look_user) ! real value to use PPTOANC1.871
PPTOANC1.872
integer fixhd(lfh) ! fixed length header PPTOANC1.873
PPTOANC1.874
integer int_const(max_len_intc) ! integer constants PPTOANC1.875
real real_const(max_len_realc) ! real constants PPTOANC1.876
PPTOANC1.877
real lev_dep_consts(1+max_len1_levdepc*max_len2_levdepc) PPTOANC1.878
real row_dep_consts(1+max_len1_rowdepc*max_len2_rowdepc) PPTOANC1.879
real col_dep_consts(1+max_len1_coldepc*max_len2_coldepc) PPTOANC1.880
real extra_const(max_len_extcnst) PPTOANC1.881
real dumphist(len_dumphist) PPTOANC1.882
PPTOANC1.883
! Local dynamic arrays: PPTOANC1.884
PPTOANC1.885
integer pp_int(45) PPTOANC1.886
integer lookup(45,len2_lookup_max) ! Integer part of lookup PPTOANC1.887
! table array PPTOANC1.888
PPTOANC1.889
real pp_real(19) PPTOANC1.890
real rlookup(46:64,len2_lookup_max) ! Integer part of lookup PPTOANC1.891
! table array PPTOANC1.892
PPTOANC1.893
integer lookup_all(len1_lookup_all,len2_lookup_max) PPTOANC1.894
! Whole lookup table array PPTOANC1.895
PPTOANC1.896
integer cfi1(len_cfi(1)) ! compressed field index PPTOANC1.897
integer cfi2(len_cfi(2)) ! arrays PPTOANC1.898
integer cfi3(len_cfi(3)) PPTOANC1.899
PPTOANC1.900
integer n_pp_flds(max_n_pp_files) ! Number of pp fields array PPTOANC1.901
PPTOANC1.902
logical lsmask(len1_coldepc*len1_rowdepc) ! land sea mask PPTOANC1.903
! for wave dump PPTOANC1.904
real fields_const(len1_flddepc,len2_flddepc) PPTOANC1.905
! array for fields of constants PPTOANC1.906
PPTOANC1.907
! Function & Subroutine calls: PPTOANC1.908
integer FIND_NAMELIST PPTOANC1.909
PPTOANC1.910
!- End of header PPTOANC1.911
PPTOANC1.912
namelist /header_data/ fixhd,int_const,real_const, PPTOANC1.913
& lev_dep_consts,row_dep_consts, PPTOANC1.914
& col_dep_consts,extra_const, PPTOANC1.915
& ifld_int, item_int, ival_int, PPTOANC1.916
& ifld_real, item_real, rval_real PPTOANC1.917
PPTOANC1.918
CL 0. Preliminaries PPTOANC1.919
PPTOANC1.920
CL 0.1 Check sizes namelist dimensions do not exceed the maximum PPTOANC1.936
CL dimensions and intialise arrays. PPTOANC1.937
PPTOANC1.938
PPTOANC1.939
if (len_intc.gt.max_len_intc) then PPTOANC1.940
write (6,*) ' len_intc in namelist is too big.' PPTOANC1.941
write (6,*) ' Max value allowed is ',max_len_intc PPTOANC1.942
write (6,*) ' Increase MAX_LEN_INTC in program' PPTOANC1.943
icode = 1 PPTOANC1.944
go to 9999 ! Return PPTOANC1.945
endif PPTOANC1.946
PPTOANC1.947
if (len_realc.gt.max_len_realc) then PPTOANC1.948
write (6,*) ' len_realc in namelist is too big.' PPTOANC1.949
write (6,*) ' Max value allowed is ',max_len_realc PPTOANC1.950
write (6,*) ' Increase MAX_LEN_REALC in program' PPTOANC1.951
icode = 2 PPTOANC1.952
go to 9999 ! Return PPTOANC1.953
endif PPTOANC1.954
PPTOANC1.955
if (len1_levdepc.gt.max_len1_levdepc) then PPTOANC1.956
write (6,*) ' len1_levdpec in namelist is too big.' PPTOANC1.957
write (6,*) ' Max value allowed is ',max_len1_levdepc PPTOANC1.958
write (6,*) ' Increase MAX_LEN1_LEVDEPC in program' PPTOANC1.959
icode = 3 PPTOANC1.960
go to 9999 ! Return PPTOANC1.961
endif PPTOANC1.962
PPTOANC1.963
if (len2_levdepc.gt.max_len2_levdepc) then PPTOANC1.964
write (6,*) ' len2_levdpec in namelist is too big.' PPTOANC1.965
write (6,*) ' Max value allowed is ',max_len2_levdepc PPTOANC1.966
write (6,*) ' Increase MAX_LEN2_LEVDEPC in program' PPTOANC1.967
icode = 4 PPTOANC1.968
go to 9999 ! Return PPTOANC1.969
endif PPTOANC1.970
PPTOANC1.971
if (len1_rowdepc.gt.max_len1_rowdepc) then PPTOANC1.972
write (6,*) ' len1_rowdpec in namelist is too big.' PPTOANC1.973
write (6,*) ' Max value allowed is ',max_len1_rowdepc PPTOANC1.974
write (6,*) ' Increase MAX_LEN1_ROWDEPC in program' PPTOANC1.975
icode = 5 PPTOANC1.976
endif PPTOANC1.977
PPTOANC1.978
if (len2_rowdepc.gt.max_len2_rowdepc) then PPTOANC1.979
write (6,*) ' len2_rowdpec in namelist is too big.' PPTOANC1.980
write (6,*) ' Max value allowed is ',max_len2_rowdepc PPTOANC1.981
write (6,*) ' Increase MAX_LEN2_ROWDEPC in program' PPTOANC1.982
icode = 6 PPTOANC1.983
go to 9999 ! Return PPTOANC1.984
endif PPTOANC1.985
PPTOANC1.986
if (len1_coldepc.gt.max_len1_coldepc) then PPTOANC1.987
write (6,*) ' len1_coldpec in namelist is too big.' PPTOANC1.988
write (6,*) ' Max value allowed is ',max_len1_coldepc PPTOANC1.989
write (6,*) ' Increase MAX_LEN1_COLDEPC in program' PPTOANC1.990
icode = 7 PPTOANC1.991
go to 9999 ! Return PPTOANC1.992
endif PPTOANC1.993
PPTOANC1.994
if (len2_coldepc.gt.max_len2_coldepc) then PPTOANC1.995
write (6,*) ' len2_coldepc in namelist is too big.' PPTOANC1.996
write (6,*) ' Max value allowed is ',max_len2_coldepc PPTOANC1.997
write (6,*) ' Increase MAX_LEN2_COLDEPC in program' PPTOANC1.998
icode = 8 PPTOANC1.999
go to 9999 ! Return PPTOANC1.1000
endif PPTOANC1.1001
PPTOANC1.1002
if (len_extcnst.gt.max_len_extcnst) then PPTOANC1.1003
write (6,*) ' len_extcnst in namelist is too big.' PPTOANC1.1004
write (6,*) ' Max value allowed is ',max_len_extcnst PPTOANC1.1005
write (6,*) ' Increase MAX_LEN_EXTCNST in program' PPTOANC1.1006
icode = 11 PPTOANC1.1007
go to 9999 ! Return PPTOANC1.1008
endif PPTOANC1.1009
PPTOANC1.1010
! Initialise namelist arrays. PPTOANC1.1011
do n=1,max_len2_levdepc PPTOANC1.1012
do m=1,max_len1_levdepc PPTOANC1.1013
lev_dep_consts(m+(n-1)*max_len1_levdepc)=0.0 PPTOANC1.1014
end do PPTOANC1.1015
end do PPTOANC1.1016
PPTOANC1.1017
do n=1,max_len2_rowdepc PPTOANC1.1018
do m=1,max_len1_rowdepc PPTOANC1.1019
row_dep_consts(m+(n-1)*max_len1_rowdepc)=0.0 PPTOANC1.1020
end do PPTOANC1.1021
end do PPTOANC1.1022
PPTOANC1.1023
do n=1,max_len2_coldepc PPTOANC1.1024
do m=1,max_len1_coldepc PPTOANC1.1025
col_dep_consts(m+(n-1)*max_len1_coldepc)=0.0 PPTOANC1.1026
end do PPTOANC1.1027
end do PPTOANC1.1028
PPTOANC1.1029
do n=1,max_len_extcnst PPTOANC1.1030
extra_const(n)=0.0 PPTOANC1.1031
end do PPTOANC1.1032
PPTOANC1.1033
do n=1,len_dumphist PPTOANC1.1034
dumphist(n)=0.0 PPTOANC1.1035
end do PPTOANC1.1036
PPTOANC1.1037
CL PPTOANC1.1038
CL 0.2 Read wave land/sea mask PPTOANC1.1039
CL PPTOANC1.1040
if (wave .and. compress) then PPTOANC1.1041
PPTOANC1.1042
write(6,*) 'reading in landsea mask for waves from pp dataset' PPTOANC1.1043
PPTOANC1.1044
call get_file(ftin2,LEVELS,80,icode) PPTOANC1.1045
call file_open(ftin2,LEVELS,80,0,1,icode) PPTOANC1.1046
if (icode.gt.0) then PPTOANC1.1047
write (6,*) 'Problem with opening wave landsea mask on Unit' PPTOANC1.1048
& ,ftin2 PPTOANC1.1049
icode = 25 PPTOANC1.1050
go to 9999 ! Return PPTOANC1.1051
endif PPTOANC1.1052
PPTOANC1.1053
read(ftin2) pp_int,pp_real PPTOANC1.1054
read(ftin2) lsmask PPTOANC1.1055
PPTOANC1.1056
close(ftin2) PPTOANC1.1057
PPTOANC1.1058
C reset so sea points are true PPTOANC1.1059
C PPTOANC1.1060
n_sea_points=0 PPTOANC1.1061
PPTOANC1.1062
do i=1,len1_coldepc*len1_rowdepc PPTOANC1.1063
PPTOANC1.1064
lsmask(i)=.not. lsmask(i) PPTOANC1.1065
PPTOANC1.1066
if(lsmask(i)) then PPTOANC1.1067
n_sea_points=n_sea_points+1 PPTOANC1.1068
end if PPTOANC1.1069
PPTOANC1.1070
enddo PPTOANC1.1071
PPTOANC1.1072
print*,'n_sea_points set to ', n_sea_points PPTOANC1.1073
fldsizelev(1)=n_sea_points PPTOANC1.1074
PPTOANC1.1075
endif ! wave .and. compress PPTOANC1.1076
PPTOANC1.1077
CL 0.3 Calculate number of fields (len2_lookup), which depends on PPTOANC1.1078
CL nlevs_code. PPTOANC1.1079
PPTOANC1.1080
len2_lookup = 0 PPTOANC1.1081
len2_step = 0 PPTOANC1.1082
PPTOANC1.1083
do i =1,field_types PPTOANC1.1084
len2_step = n_times * nlevs_code(i) PPTOANC1.1085
len2_lookup = len2_lookup + len2_step PPTOANC1.1086
end do PPTOANC1.1087
PPTOANC1.1088
print*,' ' PPTOANC1.1089
print*,'len2_lookup = ',len2_lookup PPTOANC1.1090
PPTOANC1.1091
CL 0.4 Initialise arrays PPTOANC1.1092
PPTOANC1.1093
do n=1,max_n_pp_files PPTOANC1.1094
n_pp_flds(n)=0 PPTOANC1.1095
enddo PPTOANC1.1096
PPTOANC1.1097
do n = 1, len_look_user PPTOANC1.1098
ifld_int(n) = imdi PPTOANC1.1099
item_int(n) = imdi PPTOANC1.1100
ival_int(n) = imdi PPTOANC1.1101
ifld_real(n) = imdi PPTOANC1.1102
item_real(n) = imdi PPTOANC1.1103
rval_real(n) = rmdi PPTOANC1.1104
end do PPTOANC1.1105
PPTOANC1.1106
do i = 1,len_dumphist PPTOANC1.1107
dumphist(i)= 0.0 PPTOANC1.1108
end do PPTOANC1.1109
PPTOANC1.1110
CL 0.5 Read StashMaster files PPTOANC1.1111
PPTOANC1.1112
IROW_NUMBER=0 PPTOANC1.1113
CALL GETPPX(22,2,'STASHmaster_A',IROW_NUMBER, PPTOANC1.1114
*CALL ARGPPX PPTOANC1.1115
& ICODE,CMESSAGE) PPTOANC1.1116
CALL GETPPX(22,2,'STASHmaster_O',IROW_NUMBER, PPTOANC1.1117
*CALL ARGPPX PPTOANC1.1118
& ICODE,CMESSAGE) PPTOANC1.1119
CALL GETPPX(22,2,'STASHmaster_S',IROW_NUMBER, PPTOANC1.1120
*CALL ARGPPX PPTOANC1.1121
& ICODE,CMESSAGE) PPTOANC1.1122
CALL GETPPX(22,2,'STASHmaster_W',IROW_NUMBER, PPTOANC1.1123
*CALL ARGPPX PPTOANC1.1124
& ICODE,CMESSAGE) PPTOANC1.1125
PPTOANC1.1126
CL 1. Read headers of all input data PPTOANC1.1127
PPTOANC1.1128
CL 1.0 Open the UM/ancillary file PPTOANC1.1129
PPTOANC1.1130
call get_file(ftout,ANCFILE,80,icode) PPTOANC1.1131
call file_open (ftout,ANCFILE,80,1,1,icode) PPTOANC1.1132
if (icode.gt.0) then PPTOANC1.1133
write (6,*) ' Problem with opening Ancillary File on Unit, ' PPTOANC1.1134
ICODE = 2 PPTOANC1.1135
go to 9999 ! Return PPTOANC1.1136
endif PPTOANC1.1137
PPTOANC1.1138
C note these values are used in pp_table so need to be set here PPTOANC1.1139
C before the do-loops PPTOANC1.1140
C * set default lev_dep_consts for WAVE frequency using the PPTOANC1.1141
C factor 1.1 PPTOANC1.1142
C * as set in real_const(15) by namelist PPTOANC1.1143
C * need to set frmin as lev_dep_consts(1) in namelist input PPTOANC1.1144
C * pick up the CO value from namelist input HEADER value PPTOANC1.1145
PPTOANC1.1146
if (wave) then PPTOANC1.1147
PPTOANC1.1148
rewind(5) PPTOANC1.1149
I=FIND_NAMELIST(5,"HEADER_DATA") PPTOANC1.1150
PPTOANC1.1151
If(I.eq.0)then PPTOANC1.1152
read(5,HEADER_DATA) PPTOANC1.1153
Else PPTOANC1.1154
write(6,*)'Cannot find namelist HEADER_DATA' PPTOANC1.1155
End if PPTOANC1.1156
PPTOANC1.1157
print*,'real_const(15) is',real_const(15) PPTOANC1.1158
print*,'lev_dep_consts(1,1)=',lev_dep_consts(1) PPTOANC1.1159
PPTOANC1.1160
do m=2,len1_levdepc PPTOANC1.1161
lev_dep_consts(m) = real_const(15)*lev_dep_consts(m-1) PPTOANC1.1162
enddo PPTOANC1.1163
PPTOANC1.1164
endif PPTOANC1.1165
PPTOANC1.1166
CL 1.1 Read through all data sets calculating the ancillary PPTOANC1.1167
CL file headers. Loop over n_times then field_types. PPTOANC1.1168
PPTOANC1.1169
runtot=1 ! points to start point in data array for next field PPTOANC1.1170
fieldn=0 ! field number counter PPTOANC1.1171
PPTOANC1.1172
do 20,n=1,n_times PPTOANC1.1173
PPTOANC1.1174
do 15,m=1,field_types PPTOANC1.1175
PPTOANC1.1176
fieldn = fieldn + 1 PPTOANC1.1177
PPTOANC1.1178
CL 1.2 do steps which are independent of the level first PPTOANC1.1179
CL Read the pp header for each field PPTOANC1.1180
PPTOANC1.1181
if (n_pp_files.eq.1) then PPTOANC1.1182
ftin1= unit_no(1) PPTOANC1.1183
else PPTOANC1.1184
if (field_order) then PPTOANC1.1185
ftin1= unit_no(n) PPTOANC1.1186
else PPTOANC1.1187
ftin1= unit_no(m) PPTOANC1.1188
endif PPTOANC1.1189
endif PPTOANC1.1190
PPTOANC1.1191
call read_pp_header (ftin1,pp_int,pp_real,ibm_to_cray) PPTOANC1.1192
PPTOANC1.1193
n_pp_flds(ftin1-19) = n_pp_flds(ftin1-19)+1 PPTOANC1.1194
write (6,*) 'Field No ',fieldn,' read in. From PP File ',ftin1-19, PPTOANC1.1195
+ ' Field No ',n_pp_flds(ftin1-19) PPTOANC1.1196
PPTOANC1.1197
PPTOANC1.1198
if (pphead) then PPTOANC1.1199
write (6,*) 'pp_int for field ',fieldn PPTOANC1.1200
write (6,*) (pp_int(j),j=1,45) PPTOANC1.1201
write (6,*) 'pp_real for field ',fieldn PPTOANC1.1202
write (6,*) (pp_real(j),j=1,19) PPTOANC1.1203
endif PPTOANC1.1204
PPTOANC1.1205
PPTOANC1.1206
CL 1.3 Extract the data dimensions and determine whether field PPTOANC1.1207
CL is on tracer or velocity grid and how many levels this PPTOANC1.1208
CL field has. PPTOANC1.1209
PPTOANC1.1210
rows = pp_int(lbrow) PPTOANC1.1211
columns = pp_int(lbnpt) PPTOANC1.1212
np = pp_int(lblrec) PPTOANC1.1213
len_extra = MAX(pp_int(lbext), 0) ! extra data in pp-field PPTOANC1.1214
pp_int(lbext )= 0 ! get rid of extra data PPTOANC1.1215
PPTOANC1.1216
do i = 1, number_of_codes PPTOANC1.1217
if ( pp_int(item_code) .eq. stash_code(i) ) then PPTOANC1.1218
PPTOANC1.1219
CL Get grid and number of levels for this stash code PPTOANC1.1220
tracer_grid = grid_of_tracer(i) PPTOANC1.1221
nlevs_this_code = nlevs_code(i) PPTOANC1.1222
write (6,*) ' PP Code ',pp_int(lbfc),' tracer_grid ', PPTOANC1.1223
+ tracer_grid,' nlevs_this_code ',nlevs_this_code PPTOANC1.1224
PPTOANC1.1225
CL Check field code set ; if not, set from FIELD_CODE PPTOANC1.1226
if (pp_int(lbfc).ne.field_code(i)) then PPTOANC1.1227
write (6,*) 'Field No ',fieldn,' Field code', PPTOANC1.1228
+ ' incorrect or not set. Reset from ',pp_int(lbfc), PPTOANC1.1229
+ ' to ',field_code(i) PPTOANC1.1230
pp_int(lbfc) = field_code(i) PPTOANC1.1231
endif PPTOANC1.1232
PPTOANC1.1233
go to 8 PPTOANC1.1234
end if PPTOANC1.1235
end do PPTOANC1.1236
PPTOANC1.1237
write (6,*) ' WARNING from subroutine ANC_FLD' PPTOANC1.1238
write (6,*) ' Stash code ', pp_int(item_code),' in PP Header ', PPTOANC1.1239
# ' was not found in STASH_CODE of CODES namelist.' PPTOANC1.1240
PPTOANC1.1241
8 continue PPTOANC1.1242
PPTOANC1.1243
CL 1.4 Start loop over levels PPTOANC1.1244
PPTOANC1.1245
do 10,levn= 1, nlevs_this_code PPTOANC1.1246
PPTOANC1.1247
if(levn .ne. 1) then PPTOANC1.1248
PPTOANC1.1249
fieldn = fieldn + 1 PPTOANC1.1250
PPTOANC1.1251
call read_pp_header (ftin1,pp_int,pp_real,ibm_to_cray) PPTOANC1.1252
PPTOANC1.1253
n_pp_flds(ftin1-19) = n_pp_flds(ftin1-19)+1 PPTOANC1.1254
PPTOANC1.1255
write (6,*) 'Field No ',fieldn,' read in. From PP File ' PPTOANC1.1256
+ ,ftin1-19, ' Field No ',n_pp_flds(ftin1-19) PPTOANC1.1257
PPTOANC1.1258
if (pphead) then PPTOANC1.1259
write (6,*) 'pp_int for field ',fieldn PPTOANC1.1260
write (6,*) (pp_int(j),j=1,45) PPTOANC1.1261
write (6,*) 'pp_real for field ',fieldn PPTOANC1.1262
write (6,*) (pp_real(j),j=1,19) PPTOANC1.1263
endif PPTOANC1.1264
PPTOANC1.1265
end if ! levn .ne. 1 PPTOANC1.1266
PPTOANC1.1267
CL 1.5 Set t_compress depending on wave and nlevs_this_code. PPTOANC1.1268
CL Don't compress fields of only one level. PPTOANC1.1269
PPTOANC1.1270
if (compress .and. nlevs_this_code .ne. 1) then PPTOANC1.1271
PPTOANC1.1272
t_compress = .true. PPTOANC1.1273
PPTOANC1.1274
elseif (wave .and. pp_int(lbfc).eq.38) then PPTOANC1.1275
PPTOANC1.1276
print*,'re-setting compress false for lsmask' PPTOANC1.1277
print*,'in ppheader section of anc_fld' PPTOANC1.1278
t_compress=.false. PPTOANC1.1279
PPTOANC1.1280
elseif (wave .and. pp_int(lbfc).ne.38 PPTOANC1.1281
# .and. nlevs_this_code .eq. 1) then PPTOANC1.1282
PPTOANC1.1283
t_compress = .true. PPTOANC1.1284
PPTOANC1.1285
else PPTOANC1.1286
PPTOANC1.1287
t_compress = .false. PPTOANC1.1288
PPTOANC1.1289
endif PPTOANC1.1290
PPTOANC1.1291
CL 1.6 Calculate fieldsize PPTOANC1.1292
PPTOANC1.1293
if (add_wrap_pts) then PPTOANC1.1294
if (t_compress) then PPTOANC1.1295
if(.not.wave) then PPTOANC1.1296
fieldsize= fldsizelev(levn) PPTOANC1.1297
else PPTOANC1.1298
fieldsize=n_sea_points PPTOANC1.1299
if(pp_int(lbfc).eq.38) then ! LS mask data field PPTOANC1.1300
print*,'fieldsize set uncomp for lsmask' PPTOANC1.1301
fieldsize=rows*columns PPTOANC1.1302
endif PPTOANC1.1303
endif PPTOANC1.1304
else PPTOANC1.1305
fieldsize=rows*(columns+2) PPTOANC1.1306
endif PPTOANC1.1307
else PPTOANC1.1308
if (t_compress) then PPTOANC1.1309
if (.not. wave) then PPTOANC1.1310
fieldsize= fldsizelev(levn) PPTOANC1.1311
else PPTOANC1.1312
fieldsize=n_sea_points PPTOANC1.1313
if(pp_int(lbfc).eq.38) then ! LS mask data field PPTOANC1.1314
print*,'fieldsize set uncomp for lsmask' PPTOANC1.1315
fieldsize=rows*columns PPTOANC1.1316
endif PPTOANC1.1317
endif PPTOANC1.1318
else PPTOANC1.1319
fieldsize=rows*columns PPTOANC1.1320
endif PPTOANC1.1321
endif PPTOANC1.1322
PPTOANC1.1323
CL 1.7 Set the fixed header, integer and real constants PPTOANC1.1324
PPTOANC1.1325
if (fieldn.eq.1) then PPTOANC1.1326
PPTOANC1.1327
icode = 0 PPTOANC1.1328
PPTOANC1.1329
CL Calculate no_cmp PPTOANC1.1330
PPTOANC1.1331
no_cmp = 0 PPTOANC1.1332
do i = 1, nlevels ! do not use levn in this loop PPTOANC1.1333
no_cmp = no_cmp + fldsizelev(i) PPTOANC1.1334
end do PPTOANC1.1335
PPTOANC1.1336
C PPTOANC1.1337
C note - anc_head only uses compress if .not. wave PPTOANC1.1338
C PPTOANC1.1339
call anc_head(pp_int,pp_real,rows,columns,fieldsize,len2_lookup, PPTOANC1.1340
# field_types,n_times,nlevels,n_freq_waves,n_dir_waves,no_cmp, PPTOANC1.1341
# len1_levdepc,len2_levdepc,len1_rowdepc,len2_rowdepc,len1_coldepc, PPTOANC1.1342
# len2_coldepc,len1_flddepc,len2_flddepc,len_extcnst,len_cfi, PPTOANC1.1343
# tracer_grid,add_wrap_pts,periodic,single_time,ibm_to_cray, PPTOANC1.1344
# t_compress,levdepc,rowdepc,coldepc,flddepc,extcnst,wave, PPTOANC1.1345
# lfh,fixhd,len_intc,int_const,len_realc,real_const,icode) PPTOANC1.1346
PPTOANC1.1347
if (icode.gt.0) go to 9999 ! Error detected ; Return PPTOANC1.1348
PPTOANC1.1349
C initialise header for length of data in ancillary file PPTOANC1.1350
C (reset to zero from mdi value set in anc_head) PPTOANC1.1351
fixhd(161) = 0 PPTOANC1.1352
PPTOANC1.1353
end if ! fieldn .eq. 1 PPTOANC1.1354
PPTOANC1.1355
C accumulate indicator of length of data in ancillary file PPTOANC1.1356
fixhd(161)=fixhd(161)+fieldsize PPTOANC1.1357
PPTOANC1.1358
CL 1.8 Set the lookup table for this field PPTOANC1.1359
PPTOANC1.1360
CCMH note for waves - to use frequency information in lev-dep-consts PPTOANC1.1361
CCMH need to set before call pp_table as well as in proper place. PPTOANC1.1362
CCMH so do before the loops PPTOANC1.1363
PPTOANC1.1364
call pp_table(pp_int,pp_real,len2_lookup,lookup,rlookup, PPTOANC1.1365
# fieldsize,fieldn,levn,m,runtot,number_of_codes,field_code, PPTOANC1.1366
# stash_code,add_wrap_pts,t_compress,pack32,wave,len1_levdepc, PPTOANC1.1367
# len2_levdepc,lev_dep_consts,len_realc,real_const,icode) PPTOANC1.1368
PPTOANC1.1369
if (icode.gt.0) go to 9999 ! Error detected ; Return PPTOANC1.1370
PPTOANC1.1371
CL 1.9 Read past the data part of this pp field PPTOANC1.1372
call readdata(rows,columns,ftin1,ibm_to_cray,len_extra) PPTOANC1.1373
PPTOANC1.1374
10 continue ! end of loop over levels PPTOANC1.1375
PPTOANC1.1376
15 continue ! end of loop over field_types PPTOANC1.1377
PPTOANC1.1378
20 continue ! end of loop over times PPTOANC1.1379
PPTOANC1.1380
write(6,*) '===================================' PPTOANC1.1381
write(6,*) fieldn,' PP fields have been read in' PPTOANC1.1382
write(6,*) '===================================' PPTOANC1.1383
PPTOANC1.1384
CL 2. If flddepc=t or compress = t: Read in fields of constant and PPTOANC1.1385
CL compressed field indices from levels dataset PPTOANC1.1386
PPTOANC1.1387
CL 2.1 For ocean dumps, create compressed field indices and PPTOANC1.1388
CL fields_const PPTOANC1.1389
PPTOANC1.1390
icode = 0 PPTOANC1.1391
PPTOANC1.1392
if ((compress .or. flddepc) .and. .not. wave) then PPTOANC1.1393
PPTOANC1.1394
call calc_cfi_and_fld(ftin2,nlevels,len1_coldepc, PPTOANC1.1395
& cols_nowrap,len1_rowdepc,len1_flddepc,len2_flddepc, PPTOANC1.1396
& fields_const,fldsizelev,len_cfi,cfi1,cfi2,cfi3,compress, PPTOANC1.1397
& flddepc,ibm_to_cray,add_wrap_pts,imdi,icode) PPTOANC1.1398
PPTOANC1.1399
if (icode .ne. 0) then PPTOANC1.1400
go to 9999 PPTOANC1.1401
endif PPTOANC1.1402
PPTOANC1.1403
end if PPTOANC1.1404
PPTOANC1.1405
CL PPTOANC1.1406
CL 3. Over-ride elements in header arrays PPTOANC1.1407
CL PPTOANC1.1408
C Arrays that can be over-ridden are fixed length, integer PPTOANC1.1409
C constants, real constants and level dependent constants. PPTOANC1.1410
PPTOANC1.1411
C * set default lev_dep_consts for WAVE frequency using the PPTOANC1.1412
C factor 1.1 PPTOANC1.1413
C * as set in real_const(15) by namelist PPTOANC1.1414
C * need to set frmin as lev_dep_consts(1) in namelist input PPTOANC1.1415
C * pick up the CO value from namelist input HEADER value PPTOANC1.1416
PPTOANC1.1417
CL 3.1 Read in the header_data namelist which includes the PPTOANC1.1418
CL lev_dep_consts,row_dep_consts,col_dep_consts,extra_consts PPTOANC1.1419
PPTOANC1.1420
rewind(5) PPTOANC1.1421
I=FIND_NAMELIST(5,"HEADER_DATA") PPTOANC1.1422
PPTOANC1.1423
If(I.eq.0)then PPTOANC1.1424
read(5,HEADER_DATA) PPTOANC1.1425
Else PPTOANC1.1426
write(6,*)'Cannot find namelist HEADER_DATA' PPTOANC1.1427
End if PPTOANC1.1428
write (6,*) ' ' PPTOANC1.1429
PPTOANC1.1430
CL For wave dumps calculate the lev_dep_consts again PPTOANC1.1431
PPTOANC1.1432
if (wave) then PPTOANC1.1433
PPTOANC1.1434
do m=2,len1_levdepc PPTOANC1.1435
CCC FR(M) = CO*FR(M-1) PPTOANC1.1436
lev_dep_consts(m) = real_const(15)*lev_dep_consts(m-1) PPTOANC1.1437
enddo PPTOANC1.1438
PPTOANC1.1439
endif PPTOANC1.1440
PPTOANC1.1441
CL 3.2 Amend the lookup tables PPTOANC1.1442
PPTOANC1.1443
do i = 1, len_look_user PPTOANC1.1444
PPTOANC1.1445
if ( ifld_int(i) .ne. imdi ) then PPTOANC1.1446
PPTOANC1.1447
if ( ifld_int(i) .eq. 0 ) then PPTOANC1.1448
do j = 1, len2_lookup PPTOANC1.1449
lookup( item_int(i) , j ) = ival_int(i) PPTOANC1.1450
end do PPTOANC1.1451
else PPTOANC1.1452
lookup( item_int(i) , ifld_int(i) ) = ival_int(i) PPTOANC1.1453
end if PPTOANC1.1454
PPTOANC1.1455
end if ! ifld_int(i) .ne. imdi PPTOANC1.1456
PPTOANC1.1457
if ( ifld_real(i) .ne. imdi ) then PPTOANC1.1458
PPTOANC1.1459
if ( ifld_real(i) .eq. 0 ) then PPTOANC1.1460
do j = 1, len2_lookup PPTOANC1.1461
rlookup( item_real(i) , j ) = rval_real(i) PPTOANC1.1462
end do PPTOANC1.1463
else PPTOANC1.1464
rlookup( item_real(i) , ifld_real(i) ) = rval_real(i) PPTOANC1.1465
end if PPTOANC1.1466
PPTOANC1.1467
end if ! ifld_real(i) .ne. imdi PPTOANC1.1468
PPTOANC1.1469
end do ! i = 1, len_look_user PPTOANC1.1470
PPTOANC1.1471
CL 3.3 Print out headers to screen PPTOANC1.1472
PPTOANC1.1473
if (pphead) then PPTOANC1.1474
PPTOANC1.1475
write(6,*) ' ' PPTOANC1.1476
write(6,*) 'fixhd' PPTOANC1.1477
write(6,*) (fixhd(j),j=1,161) PPTOANC1.1478
write(6,*) ' ' PPTOANC1.1479
write(6,*) 'int_const ; length ',len_intc PPTOANC1.1480
write(6,*) (int_const(j),j=1,len_intc) PPTOANC1.1481
write(6,*) ' ' PPTOANC1.1482
write(6,*) 'real_const ; length ',len_realc PPTOANC1.1483
write(6,*) (real_const(j),j=1,len_realc) PPTOANC1.1484
PPTOANC1.1485
if (levdepc) then PPTOANC1.1486
write(6,*) ' ' PPTOANC1.1487
write(6,*) 'level dependent constants ' PPTOANC1.1488
do j=1,len2_levdepc PPTOANC1.1489
ipos=(j-1)*len1_levdepc PPTOANC1.1490
write(6,*) 'variable ',j PPTOANC1.1491
write(6,*) (lev_dep_consts(ipos+i),i=1,len1_levdepc) PPTOANC1.1492
enddo PPTOANC1.1493
endif PPTOANC1.1494
write(6,*) ' ' PPTOANC1.1495
PPTOANC1.1496
if (rowdepc) then PPTOANC1.1497
write(6,*) ' ' PPTOANC1.1498
write(6,*) 'row dependent constants ' PPTOANC1.1499
do j=1,len2_rowdepc PPTOANC1.1500
ipos=(j-1)*len1_rowdepc PPTOANC1.1501
write(6,*) 'variable ',j PPTOANC1.1502
write(6,*) (row_dep_consts(ipos+i),i=1,len1_rowdepc) PPTOANC1.1503
enddo PPTOANC1.1504
endif PPTOANC1.1505
write(6,*) ' ' PPTOANC1.1506
PPTOANC1.1507
if (coldepc) then PPTOANC1.1508
write(6,*) ' ' PPTOANC1.1509
write(6,*) 'column dependent constants ' PPTOANC1.1510
do j=1,len2_coldepc PPTOANC1.1511
ipos=(j-1)*len1_coldepc PPTOANC1.1512
write(6,*) 'variable ',j PPTOANC1.1513
write(6,*) (col_dep_consts(ipos+i),i=1,len1_coldepc) PPTOANC1.1514
enddo PPTOANC1.1515
endif PPTOANC1.1516
write(6,*) ' ' PPTOANC1.1517
PPTOANC1.1518
if (flddepc) then PPTOANC1.1519
write(6,*) ' ' PPTOANC1.1520
write(6,*) 'fields constants' PPTOANC1.1521
write(6,*)' len1_flddepc = ',len1_flddepc PPTOANC1.1522
write(6,*)' len2_flddepc = ',len2_flddepc PPTOANC1.1523
endif PPTOANC1.1524
write(6,*) ' ' PPTOANC1.1525
PPTOANC1.1526
if (extcnst) then PPTOANC1.1527
write(6,*) ' ' PPTOANC1.1528
write(6,*) 'extra constants ' PPTOANC1.1529
write(6,*) (extra_const(i),i=1,len_extcnst) PPTOANC1.1530
endif PPTOANC1.1531
write(6,*) ' ' PPTOANC1.1532
PPTOANC1.1533
endif PPTOANC1.1534
CL PPTOANC1.1535
CL 4. Write out header data to ancillary field file PPTOANC1.1536
CL PPTOANC1.1537
PPTOANC1.1538
CL 4.1 Write out fixed, integer and real constants headers. PPTOANC1.1539
CL Set values for use in WRITHEAD and convert lookup and rlookup PPTOANC1.1540
CL into one array lookup_all using subroutine conv_real PPTOANC1.1541
PPTOANC1.1542
len_data=fixhd(161) PPTOANC1.1543
PPTOANC1.1544
call conv_real(rlookup,lookup_all,len2_lookup) PPTOANC1.1545
PPTOANC1.1546
do i=1,len2_lookup PPTOANC1.1547
lookup_all(1:45,i) = lookup(1:45,i) PPTOANC1.1548
end do PPTOANC1.1549
PPTOANC1.1550
! If logical lwfio (set in namelist LOGICALS) is true then set the PPTOANC1.1551
! LBEGIN and LBNREC fields in the LOOKUP Headers for VN 16 Type PPTOANC1.1552
! Dumpfiles. PPTOANC1.1553
if (lwfio) then PPTOANC1.1554
PPTOANC1.1555
Call set_dumpfile_address(fixhd,lfh, PPTOANC1.1556
& lookup_all,len1_lookup_all,len2_lookup, PPTOANC1.1557
& number_of_data_words_in_memory, PPTOANC1.1558
& number_of_data_words_on_disk, PPTOANC1.1559
& disk_address) PPTOANC1.1560
PPTOANC1.1561
end if PPTOANC1.1562
PPTOANC1.1563
CL 4.2 Use WRITHEAD to write the headers and constants PPTOANC1.1564
PPTOANC1.1565
CALL WRITHEAD(ftout,fixhd,lfh,int_const,len_intc, PPTOANC1.1566
& real_const,len_realc,lev_dep_consts,len1_levdepc,len2_levdepc, PPTOANC1.1567
& row_dep_consts,len1_rowdepc,len2_rowdepc,col_dep_consts, PPTOANC1.1568
& len1_coldepc,len2_coldepc,fields_const,len1_flddepc, PPTOANC1.1569
& len2_flddepc,extra_const,len_extcnst,dumphist,len_dumphist, PPTOANC1.1570
& cfi1,len_cfi(1),cfi2,len_cfi(2),cfi3,len_cfi(3),lookup_all, PPTOANC1.1571
C & len1_lookup_all,len2_lookup,len_data,start_block,icode, PPTOANC1.1572
C & cmessage) PPTOANC1.1573
& len1_lookup_all,len2_lookup,len_data, PPTOANC1.1574
*CALL ARGPPX PPTOANC1.1575
& start_block,icode,cmessage) PPTOANC1.1576
PPTOANC1.1577
CL 5.0 Write out (rest of) data to ancillary file PPTOANC1.1578
PPTOANC1.1579
CL 5.1 Return to start of pp input pp fields files PPTOANC1.1580
PPTOANC1.1581
write (6,*) ' ' UDR3F405.223
do n=1,n_pp_files UDR3F405.224
rewind 19+n UDR3F405.225
write (6,*) ' Rewinding PP file on Unit No ',19+n UDR3F405.226
end do UDR3F405.227
write (6,*) ' ' UDR3F405.228
PPTOANC1.1594
CL 5.2 Start loop over fields PPTOANC1.1595
PPTOANC1.1596
fieldn=0 ! field number counter PPTOANC1.1597
PPTOANC1.1598
do 60,n=1,n_times PPTOANC1.1599
PPTOANC1.1600
do 50,m=1,field_types PPTOANC1.1601
PPTOANC1.1602
CL 5.3 Do steps which are independant of level first PPTOANC1.1603
PPTOANC1.1604
if (n_pp_files.eq.1) then PPTOANC1.1605
ftin1= unit_no(1) PPTOANC1.1606
else PPTOANC1.1607
if (field_order) then PPTOANC1.1608
ftin1= unit_no(n) PPTOANC1.1609
else PPTOANC1.1610
ftin1= unit_no(m) PPTOANC1.1611
endif PPTOANC1.1612
endif PPTOANC1.1613
PPTOANC1.1614
fieldn = fieldn + 1 PPTOANC1.1615
PPTOANC1.1616
CL 5.4 Read pp header and determine length of field to PPTOANC1.1617
CL be output to ancillary file PPTOANC1.1618
PPTOANC1.1619
call read_pp_header (ftin1,pp_int,pp_real,ibm_to_cray) PPTOANC1.1620
PPTOANC1.1621
C (* extract the data dimensions and tracer/velocity grid type *) PPTOANC1.1622
PPTOANC1.1623
rows = pp_int(lbrow) PPTOANC1.1624
columns = pp_int(lbnpt) PPTOANC1.1625
len_extra = MAX(pp_int(lbext), 0) ! extra data in pp-field PPTOANC1.1626
PPTOANC1.1627
do i = 1, number_of_codes PPTOANC1.1628
if ( pp_int(lbfc) .eq. field_code(i) ) then PPTOANC1.1629
tracer_grid = grid_of_tracer(i) PPTOANC1.1630
nlevs_this_code=nlevs_code(i) PPTOANC1.1631
go to 30 PPTOANC1.1632
end if PPTOANC1.1633
end do PPTOANC1.1634
PPTOANC1.1635
30 continue PPTOANC1.1636
PPTOANC1.1637
CL 5.5 Start loop over levels PPTOANC1.1638
PPTOANC1.1639
do 40,levn = 1, nlevs_this_code PPTOANC1.1640
PPTOANC1.1641
if (levn .ne. 1) then PPTOANC1.1642
fieldn = fieldn + 1 PPTOANC1.1643
call read_pp_header(ftin1,pp_int,pp_real,ibm_to_cray) PPTOANC1.1644
end if PPTOANC1.1645
PPTOANC1.1646
CL 5.6 Set t_compress which depends on wave and nlevs_this_code PPTOANC1.1647
PPTOANC1.1648
if (compress .and. nlevs_this_code .ne. 1) then PPTOANC1.1649
PPTOANC1.1650
t_compress = .true. PPTOANC1.1651
PPTOANC1.1652
elseif (wave .and. pp_int(lbfc).eq.38) then PPTOANC1.1653
PPTOANC1.1654
print*,'re-setting compress false for lsmask' PPTOANC1.1655
print*,'in ppheader section of anc_fld' PPTOANC1.1656
t_compress = .false. PPTOANC1.1657
PPTOANC1.1658
else PPTOANC1.1659
PPTOANC1.1660
t_compress = .false. PPTOANC1.1661
PPTOANC1.1662
endif PPTOANC1.1663
PPTOANC1.1664
CL 5.7 Calculate fieldsize PPTOANC1.1665
PPTOANC1.1666
if (add_wrap_pts) then PPTOANC1.1667
if (t_compress) then PPTOANC1.1668
if(.not.wave) then PPTOANC1.1669
fieldsize= fldsizelev(levn) PPTOANC1.1670
else PPTOANC1.1671
fieldsize=n_sea_points PPTOANC1.1672
if(pp_int(lbfc).eq.38) then ! LS mask data field PPTOANC1.1673
print*,'fieldsize set uncomp for lsmask' PPTOANC1.1674
fieldsize=rows*columns PPTOANC1.1675
endif PPTOANC1.1676
endif PPTOANC1.1677
else PPTOANC1.1678
fieldsize=rows*(columns+2) PPTOANC1.1679
endif PPTOANC1.1680
else PPTOANC1.1681
if (t_compress) then PPTOANC1.1682
if (.not. wave) then PPTOANC1.1683
fieldsize= fldsizelev(levn) PPTOANC1.1684
else PPTOANC1.1685
fieldsize=n_sea_points PPTOANC1.1686
if(pp_int(lbfc).eq.38) then ! LS mask data field PPTOANC1.1687
print*,'fieldsize set uncomp for lsmask' PPTOANC1.1688
fieldsize=rows*columns PPTOANC1.1689
endif PPTOANC1.1690
endif PPTOANC1.1691
else PPTOANC1.1692
fieldsize=rows*columns PPTOANC1.1693
endif PPTOANC1.1694
PPTOANC1.1695
endif PPTOANC1.1696
PPTOANC1.1697
CL 5.8 Call subroutine data to write the fields to the dump/ancillary PPTOANC1.1698
CL file. PPTOANC1.1699
PPTOANC1.1700
call dataw(rows,columns,fieldsize,nlevels,levn,len_extra, PPTOANC1.1701
# fieldn,len1_lookup_all,lookup_all,fixhd, PPTOANC1.1702
# len_cfi, cfi1, cfi2, cfi3,fldsizelev,ftin1,ftout, PPTOANC1.1703
# tracer_grid,add_wrap_pts,ibm_to_cray,t_compress,rmdi_input, PPTOANC1.1704
! # wave,lsmask) PPTOANC1.1705
# wave,lsmask, PPTOANC1.1706
*CALL ARGPPX PPTOANC1.1707
# icode) PPTOANC1.1708
PPTOANC1.1709
40 continue PPTOANC1.1710
PPTOANC1.1711
50 continue PPTOANC1.1712
PPTOANC1.1713
60 continue PPTOANC1.1714
PPTOANC1.1715
write (6,*) '========================================' PPTOANC1.1716
write (6,*) fieldn,' fields written to Ancillary File' PPTOANC1.1717
write (6,*) '========================================' PPTOANC1.1718
PPTOANC1.1719
9999 continue PPTOANC1.1720
return PPTOANC1.1721
end PPTOANC1.1722
! PPTOANC1.1723
! Subroutine interface: PPTOANC1.1724
subroutine anc_head(pp_int,pp_real,rows,columns,fieldsize,nfields, 1,6PPTOANC1.1725
# field_types,n_times,nlevels,n_freq_waves,n_dir_waves,no_cmp, PPTOANC1.1726
# len1_levdepc,len2_levdepc,len1_rowdepc,len2_rowdepc,len1_coldepc, PPTOANC1.1727
# len2_coldepc,len1_flddepc,len2_flddepc,len_extcnst,len_cfi, PPTOANC1.1728
# tracer_grid,add_wrap_pts,periodic,single_time,ibm_to_cray, PPTOANC1.1729
# compress,levdepc,rowdepc,coldepc,flddepc,extcnst,wave, PPTOANC1.1730
# lfh,fixhd,len_intc,int_const,len_realc,real_const,icode) PPTOANC1.1731
PPTOANC1.1732
implicit none PPTOANC1.1733
! PPTOANC1.1734
! Description: PPTOANC1.1735
! Creates the dump/ancillary file header. PPTOANC1.1736
! (Fixed length header,integer constants and real constants) PPTOANC1.1737
! PPTOANC1.1738
! PPTOANC1.1739
! PPTOANC1.1740
! Method: PPTOANC1.1741
! PPTOANC1.1742
! Current Code Owner: D Robinson / I Edmond PPTOANC1.1743
! PPTOANC1.1744
! History: PPTOANC1.1745
! Version Date Comment PPTOANC1.1746
! ------- ---- ------- PPTOANC1.1747
! 16/06/94 Original code. Dave Robinson PPTOANC1.1748
! 4.4 14/8/97 Consolidated in UM Ian Edmond PPTOANC1.1749
! PPTOANC1.1750
! Code Description: PPTOANC1.1751
! Language: FORTRAN 77 + common extensions. PPTOANC1.1752
! This code is written to UMDP3 v6 programming standards. PPTOANC1.1753
! PPTOANC1.1754
! Declarations: PPTOANC1.1755
! These are of the form:- PPTOANC1.1756
! INTEGER ExampleVariable !Description of variable PPTOANC1.1757
! PPTOANC1.1758
! 1.0 Global variables (*CALLed COMDECKs etc...): PPTOANC1.1759
*CALL C_MDI PPTOANC1.1760
*CALL C_PI PPTOANC1.1761
PPTOANC1.1762
! Subroutine arguments PPTOANC1.1763
! Scalar arguments with intent(in): PPTOANC1.1764
integer rows PPTOANC1.1765
integer columns PPTOANC1.1766
integer fieldsize PPTOANC1.1767
integer nfields PPTOANC1.1768
integer field_types PPTOANC1.1769
integer n_times PPTOANC1.1770
integer nlevels PPTOANC1.1771
integer n_freq_waves PPTOANC1.1772
integer n_dir_waves PPTOANC1.1773
integer no_cmp ! no. of total compressed points in compressed PPTOANC1.1774
! array PPTOANC1.1775
PPTOANC1.1776
integer len1_levdepc PPTOANC1.1777
integer len2_levdepc PPTOANC1.1778
integer len1_rowdepc PPTOANC1.1779
integer len2_rowdepc PPTOANC1.1780
integer len1_coldepc PPTOANC1.1781
integer len2_coldepc PPTOANC1.1782
integer len1_flddepc PPTOANC1.1783
integer len2_flddepc PPTOANC1.1784
integer len_extcnst PPTOANC1.1785
PPTOANC1.1786
integer lfh PPTOANC1.1787
integer len_intc PPTOANC1.1788
integer len_realc PPTOANC1.1789
PPTOANC1.1790
integer icode PPTOANC1.1791
PPTOANC1.1792
CL logical choices (IN) PPTOANC1.1793
PPTOANC1.1794
logical tracer_grid PPTOANC1.1795
logical add_wrap_pts PPTOANC1.1796
logical periodic PPTOANC1.1797
logical single_time PPTOANC1.1798
logical ibm_to_cray PPTOANC1.1799
logical compress PPTOANC1.1800
logical levdepc PPTOANC1.1801
logical rowdepc PPTOANC1.1802
logical coldepc PPTOANC1.1803
logical flddepc PPTOANC1.1804
logical extcnst PPTOANC1.1805
PPTOANC1.1806
logical wave ! T for creating wave dump PPTOANC1.1807
PPTOANC1.1808
! Array arguments with intent(in): PPTOANC1.1809
integer pp_int(45) PPTOANC1.1810
integer len_cfi(3) PPTOANC1.1811
real pp_real(19) PPTOANC1.1812
PPTOANC1.1813
! Array arguments with intent(out): PPTOANC1.1814
PPTOANC1.1815
integer fixhd(lfh) PPTOANC1.1816
integer int_const(len_intc) PPTOANC1.1817
PPTOANC1.1818
real real_const(len_realc) PPTOANC1.1819
PPTOANC1.1820
! Local Scalars PPTOANC1.1821
PPTOANC1.1822
integer ipos PPTOANC1.1823
integer i,j PPTOANC1.1824
PPTOANC1.1825
integer fvhh,fvdd,fvmm,fvyy ! hour,day,month,year first validity PPTOANC1.1826
! time PPTOANC1.1827
integer lvhh,lvdd,lvmm,lvyy ! hour,day,month,year last validity PPTOANC1.1828
! time PPTOANC1.1829
integer ivhh,ivdd,ivmm,ivyy ! hour,day,month,year interval PPTOANC1.1830
PPTOANC1.1831
logical year360 ! true for 360-day calendar PPTOANC1.1832
logical l_first_vt PPTOANC1.1833
logical l_last_vt PPTOANC1.1834
PPTOANC1.1835
integer cdays ! century days PPTOANC1.1836
integer chours ! century hours PPTOANC1.1837
integer new_cdays ! new century days PPTOANC1.1838
integer new_chours! new century hours PPTOANC1.1839
integer ihr,idy,imn PPTOANC1.1840
PPTOANC1.1841
! Function & Subroutine calls: PPTOANC1.1842
PPTOANC1.1843
integer FIND_NAMELIST PPTOANC1.1844
PPTOANC1.1845
!- End of header PPTOANC1.1846
PPTOANC1.1847
namelist /first_vt/ fvhh,fvdd,fvmm,fvyy PPTOANC1.1848
namelist /last_vt/ lvhh,lvdd,lvmm,lvyy PPTOANC1.1849
namelist /interval/ year360,ivhh,ivdd,ivmm,ivyy PPTOANC1.1850
PPTOANC1.1851
PPTOANC1.1852
CL 1. Set fixed header PPTOANC1.1853
PPTOANC1.1854
CL 1.0 Initialise to missing data PPTOANC1.1855
C (* set dimensions of all arrays to 1 *) PPTOANC1.1856
PPTOANC1.1857
call init_flh (fixhd,lfh) PPTOANC1.1858
PPTOANC1.1859
CL 1.1 First 9 elements in header DEFAULTS PPTOANC1.1860
PPTOANC1.1861
fixhd(2)=2 ! indicator for the ocean PPTOANC1.1862
fixhd(3)=4 ! depth coordinates PPTOANC1.1863
fixhd(4)=0 ! global grid PPTOANC1.1864
fixhd(5)=4 ! ancillary fields dataset PPTOANC1.1865
fixhd(8)=2 ! Calendar indicator PPTOANC1.1866
fixhd(9)=1 ! Indicator for grid staggering PPTOANC1.1867
PPTOANC1.1868
CL 1.2 Set dates PPTOANC1.1869
PPTOANC1.1870
if (periodic) then PPTOANC1.1871
fixhd(10)=2 PPTOANC1.1872
else if (single_time) then PPTOANC1.1873
fixhd(10)=0 PPTOANC1.1874
else PPTOANC1.1875
fixhd(10)=1 PPTOANC1.1876
end if PPTOANC1.1877
PPTOANC1.1878
fixhd(12)=401 ! UM Version number PPTOANC1.1879
PPTOANC1.1880
C (* first validity time *) PPTOANC1.1881
C (* fixhd(21-27) *) PPTOANC1.1882
PPTOANC1.1883
fvhh = 0 PPTOANC1.1884
fvdd = 0 PPTOANC1.1885
fvmm = 0 PPTOANC1.1886
fvyy = 0 PPTOANC1.1887
PPTOANC1.1888
rewind(5) PPTOANC1.1889
I=FIND_NAMELIST(5,"FIRST_VT") PPTOANC1.1890
PPTOANC1.1891
If(I.eq.0)then PPTOANC1.1892
read (5,FIRST_VT) PPTOANC1.1893
Else PPTOANC1.1894
write(6,*)'Cannot find namelist FIRST_VT' PPTOANC1.1895
End if PPTOANC1.1896
write (6,*) ' ' PPTOANC1.1897
write (6,*) 'FIRST_VT namelist is set up as follows:-' PPTOANC1.1898
write (6,*) ' ' PPTOANC1.1899
write (6,first_vt) PPTOANC1.1900
write (6,*) ' ' PPTOANC1.1901
PPTOANC1.1902
C Test if first VT has been provided in namelist PPTOANC1.1903
l_first_vt = .not. PPTOANC1.1904
+ (fvhh.eq.0 .and. fvdd.eq.0 .and. fvmm.eq.0 .and. fvyy.eq.0) PPTOANC1.1905
PPTOANC1.1906
if (l_first_vt) then ! First VT given in namelist PPTOANC1.1907
PPTOANC1.1908
fixhd(21) = fvyy PPTOANC1.1909
fixhd(22) = fvmm PPTOANC1.1910
fixhd(23) = fvdd PPTOANC1.1911
fixhd(24) = fvhh PPTOANC1.1912
fixhd(25) = 0 PPTOANC1.1913
fixhd(26) = 0 PPTOANC1.1914
fixhd(27) = 0 PPTOANC1.1915
PPTOANC1.1916
else ! Get first VT from first PP Header PPTOANC1.1917
PPTOANC1.1918
fixhd(21) = pp_int(1) PPTOANC1.1919
fixhd(22) = pp_int(2) PPTOANC1.1920
fixhd(23) = pp_int(3) PPTOANC1.1921
fixhd(24) = pp_int(4) PPTOANC1.1922
fixhd(25) = pp_int(5) PPTOANC1.1923
fixhd(26) = 0 PPTOANC1.1924
fixhd(27) = pp_int(6) PPTOANC1.1925
PPTOANC1.1926
endif PPTOANC1.1927
PPTOANC1.1928
year360=.false. PPTOANC1.1929
ivhh = 0 PPTOANC1.1930
ivdd = 0 PPTOANC1.1931
ivmm = 0 PPTOANC1.1932
ivyy = 0 PPTOANC1.1933
PPTOANC1.1934
C (* interval is read from namelist*) PPTOANC1.1935
C (* fixhd(35-41) *) PPTOANC1.1936
PPTOANC1.1937
rewind(5) PPTOANC1.1938
I=FIND_NAMELIST(5,"INTERVAL") PPTOANC1.1939
PPTOANC1.1940
If(I.eq.0)then PPTOANC1.1941
read (5,INTERVAL) PPTOANC1.1942
Else PPTOANC1.1943
write(6,*)'Cannot find namelist INTERVAL' PPTOANC1.1944
End if PPTOANC1.1945
PPTOANC1.1946
write (6,*) ' ' PPTOANC1.1947
write (6,*) 'INTERVAL namelist is set up as follows:-' PPTOANC1.1948
write (6,*) ' ' PPTOANC1.1949
write (6,interval) PPTOANC1.1950
PPTOANC1.1951
fixhd(35) = ivyy PPTOANC1.1952
fixhd(36) = ivmm PPTOANC1.1953
fixhd(37) = ivdd PPTOANC1.1954
fixhd(38) = ivhh PPTOANC1.1955
fixhd(39) = 0 PPTOANC1.1956
fixhd(40) = 0 PPTOANC1.1957
fixhd(41) = 0 PPTOANC1.1958
PPTOANC1.1959
C (* last validity time *) PPTOANC1.1960
C (* fixhd(28-34) *) PPTOANC1.1961
PPTOANC1.1962
lvhh = 0 PPTOANC1.1963
lvdd = 0 PPTOANC1.1964
lvmm = 0 PPTOANC1.1965
lvyy = 0 PPTOANC1.1966
PPTOANC1.1967
rewind(5) PPTOANC1.1968
I=FIND_NAMELIST(5,"LAST_VT") PPTOANC1.1969
PPTOANC1.1970
If(I.eq.0)then PPTOANC1.1971
read (5,LAST_VT) PPTOANC1.1972
Else PPTOANC1.1973
write(6,*)'Cannot find namelist LAST_VT' PPTOANC1.1974
End if PPTOANC1.1975
PPTOANC1.1976
write (6,*) ' ' PPTOANC1.1977
write (6,*) 'LAST_VT namelist is set up as follows:-' PPTOANC1.1978
write (6,*) ' ' PPTOANC1.1979
write (6,last_vt) PPTOANC1.1980
PPTOANC1.1981
C Test if last VT has been provided in namelist PPTOANC1.1982
l_last_vt = .not. PPTOANC1.1983
+ (lvhh.eq.0 .and. lvdd.eq.0 .and. lvmm.eq.0 .and. lvyy.eq.0) PPTOANC1.1984
PPTOANC1.1985
if (year360) then PPTOANC1.1986
PPTOANC1.1987
if (l_last_vt) then ! Last VT given in namelist PPTOANC1.1988
PPTOANC1.1989
fixhd(28) = lvyy PPTOANC1.1990
fixhd(29) = lvmm PPTOANC1.1991
fixhd(30) = lvdd PPTOANC1.1992
fixhd(31) = lvhh PPTOANC1.1993
fixhd(32) = 0 PPTOANC1.1994
fixhd(33) = 0 PPTOANC1.1995
fixhd(34) = 0 PPTOANC1.1996
PPTOANC1.1997
else ! calculate last VT from first VT and Interval PPTOANC1.1998
PPTOANC1.1999
fixhd(33)=fixhd(26) ! seconds PPTOANC1.2000
fixhd(32)=fixhd(25) ! minutes PPTOANC1.2001
PPTOANC1.2002
ihr=fixhd(24)+ivhh*(n_times-1) PPTOANC1.2003
fixhd(31)=mod(ihr,24) PPTOANC1.2004
PPTOANC1.2005
idy=fixhd(23)+ivdd*(n_times-1)+ihr/24 PPTOANC1.2006
fixhd(30)=mod(idy-1,30)+1 PPTOANC1.2007
PPTOANC1.2008
imn=fixhd(22)+ivmm*(n_times-1)+(idy-1)/30 PPTOANC1.2009
fixhd(29)=mod(imn-1,12)+1 PPTOANC1.2010
PPTOANC1.2011
fixhd(28)=fixhd(21)+ivyy*(n_times-1)+(imn-1)/12 PPTOANC1.2012
PPTOANC1.2013
fixhd(34)=(fixhd(29)-1)*30+fixhd(30) PPTOANC1.2014
PPTOANC1.2015
endif PPTOANC1.2016
PPTOANC1.2017
else ! 365 calander files PPTOANC1.2018
PPTOANC1.2019
if (l_last_vt) then ! Last VT given in namelist PPTOANC1.2020
PPTOANC1.2021
fixhd(28) = lvyy PPTOANC1.2022
fixhd(29) = lvmm PPTOANC1.2023
fixhd(30) = lvdd PPTOANC1.2024
fixhd(31) = lvhh PPTOANC1.2025
fixhd(32) = 0 PPTOANC1.2026
fixhd(33) = 0 PPTOANC1.2027
fixhd(34) = 0 PPTOANC1.2028
PPTOANC1.2029
else ! calculate last VT from first VT and Interval PPTOANC1.2030
PPTOANC1.2031
C Check First VT and Interval first PPTOANC1.2032
C First VT is OK if FIXHD(21,22,23) are all set. PPTOANC1.2033
C Interval is OK if only IVHH and/or IVDD are used. PPTOANC1.2034
if (fixhd(21).le.0 .or. fixhd(22).le.0 .or. PPTOANC1.2035
+ fixhd(23).le.0 .or. ivmm.gt.0 .or. lvyy.gt.0) then PPTOANC1.2036
write (6,*) ' ' PPTOANC1.2037
write (6,*) ' ERROR in ANC_HEAD. Last Validity Time ??' PPTOANC1.2038
write (6,*) ' Last VT cant be calculated from first VT.' PPTOANC1.2039
write (6,*) ' Rerun job with last VT in LAST_VT namelist.' PPTOANC1.2040
write (6,*) ' ' PPTOANC1.2041
icode = 1 PPTOANC1.2042
go to 9999 ! Return PPTOANC1.2043
endif PPTOANC1.2044
PPTOANC1.2045
C (* calculate century day and hour for first validity time) PPTOANC1.2046
call date31(fixhd(23),fixhd(22),fixhd(21),cdays) PPTOANC1.2047
chours=(cdays-1)*24+fixhd(24) PPTOANC1.2048
PPTOANC1.2049
c write(6,*)'cdays=',cdays PPTOANC1.2050
c write(6,*)'chours=',chours PPTOANC1.2051
PPTOANC1.2052
C (* add time interval) PPTOANC1.2053
new_chours=chours+(n_times-1)*(ivhh+ivdd*24) PPTOANC1.2054
PPTOANC1.2055
C (* convert to new century day) PPTOANC1.2056
new_cdays=1+new_chours/24 PPTOANC1.2057
PPTOANC1.2058
C (* convert to actual date) PPTOANC1.2059
call date13(new_cdays,fixhd(30),fixhd(29),fixhd(28)) PPTOANC1.2060
fixhd(31)=new_chours-24*(new_cdays-1) PPTOANC1.2061
PPTOANC1.2062
fixhd(32) = 0 PPTOANC1.2063
fixhd(33) = 0 PPTOANC1.2064
fixhd(34) = 0 PPTOANC1.2065
PPTOANC1.2066
endif PPTOANC1.2067
PPTOANC1.2068
end if PPTOANC1.2069
PPTOANC1.2070
WRITE(6,'('' '')') PPTOANC1.2071
WRITE(6,'('' Validity Times (VT) in Ancillary File.'')') PPTOANC1.2072
WRITE(6,'('' '')') PPTOANC1.2073
WRITE(6,'('' Year Month Day Hour Min Sec DayNo PPTOANC1.2074
*'')') PPTOANC1.2075
WRITE(6,'('' First VT ='',7I5)')(FIXHD(I),I=21,27) PPTOANC1.2076
WRITE(6,'('' Last VT ='',7I5)')(FIXHD(I),I=28,34) PPTOANC1.2077
WRITE(6,'('' VT Interval ='',7I5)')(FIXHD(I),I=35,41) PPTOANC1.2078
WRITE(6,'('' '')') PPTOANC1.2079
PPTOANC1.2080
CL 1.3 Set pointers to starts of sections in ancillary file PPTOANC1.2081
PPTOANC1.2082
ipos = lfh + 1 ! position of start of integer consts PPTOANC1.2083
PPTOANC1.2084
C (* integer constants location *) PPTOANC1.2085
fixhd(100)= ipos PPTOANC1.2086
fixhd(101)=len_intc PPTOANC1.2087
ipos = ipos + len_intc PPTOANC1.2088
PPTOANC1.2089
C (* real constants location *) PPTOANC1.2090
fixhd(105)=ipos PPTOANC1.2091
fixhd(106)=len_realc PPTOANC1.2092
ipos = ipos + len_realc PPTOANC1.2093
PPTOANC1.2094
C (* levels dependent constants*) PPTOANC1.2095
PPTOANC1.2096
if (levdepc) then PPTOANC1.2097
fixhd(110) = ipos PPTOANC1.2098
fixhd(111) = len1_levdepc PPTOANC1.2099
fixhd(112) = len2_levdepc PPTOANC1.2100
ipos = ipos + len1_levdepc*len2_levdepc PPTOANC1.2101
endif PPTOANC1.2102
PPTOANC1.2103
if (rowdepc) then PPTOANC1.2104
fixhd(115) = ipos PPTOANC1.2105
fixhd(116) = len1_rowdepc PPTOANC1.2106
fixhd(117) = len2_rowdepc PPTOANC1.2107
ipos = ipos + len1_rowdepc*len2_rowdepc PPTOANC1.2108
endif PPTOANC1.2109
PPTOANC1.2110
if (coldepc) then PPTOANC1.2111
fixhd(120) = ipos PPTOANC1.2112
fixhd(121) = len1_coldepc PPTOANC1.2113
fixhd(122) = len2_coldepc PPTOANC1.2114
ipos = ipos + len1_coldepc*len2_coldepc PPTOANC1.2115
endif PPTOANC1.2116
PPTOANC1.2117
if (flddepc) then PPTOANC1.2118
fixhd(125) = ipos PPTOANC1.2119
fixhd(126) = len1_flddepc PPTOANC1.2120
fixhd(127) = len2_flddepc PPTOANC1.2121
ipos = ipos + len1_flddepc*len2_flddepc PPTOANC1.2122
endif PPTOANC1.2123
PPTOANC1.2124
if (extcnst) then PPTOANC1.2125
fixhd(130) = ipos PPTOANC1.2126
fixhd(131) = len_extcnst PPTOANC1.2127
ipos = ipos + len_extcnst PPTOANC1.2128
endif PPTOANC1.2129
PPTOANC1.2130
C (* compressed field indices *) PPTOANC1.2131
if (compress .and. .not.wave) then PPTOANC1.2132
fixhd(140) = ipos PPTOANC1.2133
fixhd(141) = len_cfi(1) PPTOANC1.2134
ipos = ipos + len_cfi(1) PPTOANC1.2135
PPTOANC1.2136
fixhd(142) = ipos PPTOANC1.2137
fixhd(143) = len_cfi(2) PPTOANC1.2138
ipos = ipos + len_cfi(2) PPTOANC1.2139
PPTOANC1.2140
fixhd(144) = ipos PPTOANC1.2141
fixhd(145) = len_cfi(3) PPTOANC1.2142
ipos = ipos + len_cfi(3) PPTOANC1.2143
PPTOANC1.2144
end if PPTOANC1.2145
PPTOANC1.2146
C (* location of lookup table *) PPTOANC1.2147
fixhd(150)=ipos PPTOANC1.2148
fixhd(151)=64 PPTOANC1.2149
fixhd(152)=nfields PPTOANC1.2150
PPTOANC1.2151
C for wave dump - number of fields in dump * PPTOANC1.2152
fixhd(153)=nfields PPTOANC1.2153
PPTOANC1.2154
C (* location of data *) PPTOANC1.2155
ipos=ipos+64*nfields PPTOANC1.2156
fixhd(160)=ipos PPTOANC1.2157
PPTOANC1.2158
C fixhd(161) is set in ancfld (it is updated after each field PPTOANC1.2159
C is read ) PPTOANC1.2160
PPTOANC1.2161
CL 2. Set Integer Constants PPTOANC1.2162
PPTOANC1.2163
do j=1,len_intc PPTOANC1.2164
int_const(j)=imdi PPTOANC1.2165
enddo PPTOANC1.2166
PPTOANC1.2167
int_const(3)=n_times PPTOANC1.2168
PPTOANC1.2169
if (add_wrap_pts) then PPTOANC1.2170
int_const(6)=columns+2 PPTOANC1.2171
else PPTOANC1.2172
int_const(6)=columns PPTOANC1.2173
end if PPTOANC1.2174
PPTOANC1.2175
C When the UM reads the ancillary files (see RPANCO1A) it checks that PPTOANC1.2176
C the number of rows in the model tracer grid (JMT) matches the number PPTOANC1.2177
C of rows declared in the integer consts; the number of rows in the PPTOANC1.2178
C velocity grid is one less than that in the tracer grid. PPTOANC1.2179
C PPTOANC1.2180
PPTOANC1.2181
if (tracer_grid) then PPTOANC1.2182
int_const(7)=rows PPTOANC1.2183
else PPTOANC1.2184
int_const(7)=rows+1 PPTOANC1.2185
end if PPTOANC1.2186
PPTOANC1.2187
int_const(8) = nlevels PPTOANC1.2188
PPTOANC1.2189
CCMHWAVES PPTOANC1.2190
if(wave) then PPTOANC1.2191
int_const(8) = n_freq_waves PPTOANC1.2192
int_const(9) = n_dir_waves PPTOANC1.2193
int_const(10)= fieldsize PPTOANC1.2194
endif PPTOANC1.2195
CCMHWAVES PPTOANC1.2196
PPTOANC1.2197
if (compress) then PPTOANC1.2198
int_const(11) = no_cmp PPTOANC1.2199
end if PPTOANC1.2200
PPTOANC1.2201
int_const(15)=field_types PPTOANC1.2202
PPTOANC1.2203
CL 3. Set real constants PPTOANC1.2204
PPTOANC1.2205
do j=1,len_realc PPTOANC1.2206
real_const(j)=rmdi PPTOANC1.2207
enddo PPTOANC1.2208
PPTOANC1.2209
C (* grid spacing) PPTOANC1.2210
real_const(1)=pp_real(17) PPTOANC1.2211
real_const(2)=abs(pp_real(15)) PPTOANC1.2212
PPTOANC1.2213
C (* lat of first row (3) and long of first point on row (4) PPTOANC1.2214
if (tracer_grid) then PPTOANC1.2215
real_const(3)=pp_real(14)+pp_real(15) PPTOANC1.2216
real_const(4)=pp_real(16)+pp_real(17) PPTOANC1.2217
else PPTOANC1.2218
real_const(3)=pp_real(14)+0.5*pp_real(15) PPTOANC1.2219
real_const(4)=pp_real(16)+0.5*pp_real(17) PPTOANC1.2220
end if PPTOANC1.2221
PPTOANC1.2222
C (* test value of the start longitude *) PPTOANC1.2223
if (real_const(4).lt.0.0) then PPTOANC1.2224
real_const(4)=real_const(4)+360.0 PPTOANC1.2225
else if (real_const(4).ge.360.0) then PPTOANC1.2226
real_const(4)=real_const(4)-360.0 PPTOANC1.2227
end if PPTOANC1.2228
PPTOANC1.2229
C (* lat and long of pseudo north pole) PPTOANC1.2230
real_const(5)=pp_real(11) PPTOANC1.2231
real_const(6)=pp_real(12) PPTOANC1.2232
PPTOANC1.2233
C WAVES PPTOANC1.2234
C direction increment PPTOANC1.2235
if(wave) then PPTOANC1.2236
real_const(13)=2.*pi/n_dir_waves PPTOANC1.2237
endif PPTOANC1.2238
PPTOANC1.2239
9999 continue PPTOANC1.2240
return PPTOANC1.2241
end PPTOANC1.2242
! PPTOANC1.2243
! Subroutine interface: PPTOANC1.2244
subroutine calc_cfi_and_fld(ftin2,nlevels,len1_coldepc, 1,1PPTOANC1.2245
& cols_nowrap,len1_rowdepc,len1_flddepc,len2_flddepc, PPTOANC1.2246
& fields_const,fldsizelev,len_cfi,cfi1,cfi2,cfi3,compress, PPTOANC1.2247
& flddepc,ibm_to_cray,add_wrap_pts,imdi,icode) PPTOANC1.2248
PPTOANC1.2249
implicit none PPTOANC1.2250
! PPTOANC1.2251
! Description: PPTOANC1.2252
! this subroutine calculates the compression arrays: PPTOANC1.2253
! cfi1(len_cfi(1)), cfi2(len_cfi(2)) and cfi3(len_cfi(3)) PPTOANC1.2254
! using an array of numbers of ocean levels at each point: PPTOANC1.2255
! levels_array(len1_coldepc,len1_rowdepc) PPTOANC1.2256
! PPTOANC1.2257
! Method: PPTOANC1.2258
! PPTOANC1.2259
! Current Code Owner: D Robinson / I Edmond PPTOANC1.2260
! PPTOANC1.2261
! History: PPTOANC1.2262
! Version Date Comment PPTOANC1.2263
! ------- ---- ------- PPTOANC1.2264
! 19/12/96 Original code. Catherine Jones PPTOANC1.2265
! 4.4 14/8/97 Consolidated in UM Ian Edmond PPTOANC1.2266
! PPTOANC1.2267
! Code Description: PPTOANC1.2268
! Language: FORTRAN 77 + common extensions. PPTOANC1.2269
! This code is written to UMDP3 v6 programming standards. PPTOANC1.2270
! PPTOANC1.2271
! Declarations: PPTOANC1.2272
! These are of the form:- PPTOANC1.2273
! INTEGER ExampleVariable !Description of variable PPTOANC1.2274
! PPTOANC1.2275
! Subroutine arguments PPTOANC1.2276
! Scalar arguments with intent(in): PPTOANC1.2277
integer ftin2 ! (in) unit numbr for levels dataset PPTOANC1.2278
integer nlevels ! (in) number of points in vertical PPTOANC1.2279
PPTOANC1.2280
integer len1_coldepc ! (in) 1st dimension of col_dep_consts PPTOANC1.2281
integer cols_nowrap ! (in) no. of points east-west PPTOANC1.2282
integer len1_rowdepc ! (in) 1st dimension of row_dep_consts PPTOANC1.2283
integer len1_flddepc ! (in) 1st dimension of fields_const PPTOANC1.2284
integer len2_flddepc ! (in) 2nd dimension of fields_const PPTOANC1.2285
integer imdi ! (in) integer missing data indicator PPTOANC1.2286
integer icode ! error code PPTOANC1.2287
PPTOANC1.2288
logical compress ! T => the dump is to be compressed PPTOANC1.2289
logical flddepc ! T => fields_const are wanted in the dump PPTOANC1.2290
logical ibm_to_cray ! T => input pp data is in IBM number PPTOANC1.2291
! format and needs to be converted to PPTOANC1.2292
! run on the Cray. PPTOANC1.2293
PPTOANC1.2294
logical add_wrap_pts ! T => add wrap points to the output field PPTOANC1.2295
PPTOANC1.2296
PPTOANC1.2297
! Array arguments with intent(in): PPTOANC1.2298
PPTOANC1.2299
PPTOANC1.2300
integer fldsizelev(nlevels) ! number of points on each compressed PPTOANC1.2301
! level PPTOANC1.2302
PPTOANC1.2303
integer len_cfi(3) ! (in) total number of sea segments PPTOANC1.2304
PPTOANC1.2305
integer cfi1(len_cfi(1)) ! (out) index array for compressed array PPTOANC1.2306
integer cfi2(len_cfi(2)) ! (out) index array for expanded array PPTOANC1.2307
integer cfi3(len1_rowdepc,nlevels) ! (out) PPTOANC1.2308
! contains number of first sea PPTOANC1.2309
! segment in each row at each levelc PPTOANC1.2310
! if there is a sea segment in the row PPTOANC1.2311
! contains number of next sea segment PPTOANC1.2312
! otherwise PPTOANC1.2313
PPTOANC1.2314
real fields_const(len1_flddepc,len2_flddepc) ! (out) array for PPTOANC1.2315
! fields of constants PPTOANC1.2316
PPTOANC1.2317
! Local scalars : PPTOANC1.2318
PPTOANC1.2319
integer columns ! no. of points east-west PPTOANC1.2320
integer rows ! no. of points north-south PPTOANC1.2321
integer i,j,k ! local loop indices PPTOANC1.2322
integer ierr ! return code from ibm2cri PPTOANC1.2323
integer count ! local counter for points in a sea segment PPTOANC1.2324
integer seg_count! local counter for number of sea segments PPTOANC1.2325
PPTOANC1.2326
character*80 levels PPTOANC1.2327
PPTOANC1.2328
! Local dynamic arrays : PPTOANC1.2329
PPTOANC1.2330
integer pp_int(45) PPTOANC1.2331
PPTOANC1.2332
real pp_real(19) PPTOANC1.2333
real*4 levels_in(cols_nowrap*len1_rowdepc) PPTOANC1.2334
! temp array for number conversion PPTOANC1.2335
real temp_levels_array(len1_coldepc,len1_rowdepc) PPTOANC1.2336
! local array of ocean levels PPTOANC1.2337
real levels_array(cols_nowrap,len1_rowdepc) PPTOANC1.2338
! local array of ocean levels PPTOANC1.2339
PPTOANC1.2340
PPTOANC1.2341
! Function & Subroutine calls: PPTOANC1.2342
integer ibm2cri PPTOANC1.2343
PPTOANC1.2344
!- End of header PPTOANC1.2345
PPTOANC1.2346
CL 1. Read the fields_const from levels dataset PPTOANC1.2347
PPTOANC1.2348
CL 1.1 Read the data from levels dataset PPTOANC1.2349
PPTOANC1.2350
call read_pp_header(ftin2,pp_int,pp_real,ibm_to_cray) PPTOANC1.2351
PPTOANC1.2352
rows = pp_int(18) PPTOANC1.2353
columns = pp_int(19) PPTOANC1.2354
PPTOANC1.2355
print*,'rows = ',rows PPTOANC1.2356
print*,'columns = ',columns PPTOANC1.2357
PPTOANC1.2358
CL 1.4 Read in levels_array and check the dataset is on the PPTOANC1.2359
CL same grid as the input pp fields. If add_wrap_pts and flddepc PPTOANC1.2360
CL then add wrap points to the levels dataset. The compression indices PPTOANC1.2361
CL are the same for an output dump with or without wrap points. PPTOANC1.2362
PPTOANC1.2363
CL Do number conversion if required PPTOANC1.2364
PPTOANC1.2365
if (ibm_to_cray) then PPTOANC1.2366
read(ftin2) levels_in PPTOANC1.2367
ierr=ibm2cri(3,rows*columns,levels_in,0,levels_array,1,64,32) PPTOANC1.2368
else PPTOANC1.2369
read(ftin2)levels_array PPTOANC1.2370
end if PPTOANC1.2371
PPTOANC1.2372
close(ftin2) PPTOANC1.2373
PPTOANC1.2374
if (add_wrap_pts) then PPTOANC1.2375
PPTOANC1.2376
if (len1_rowdepc .ne. rows) then PPTOANC1.2377
write(6,*)'wrong number of rows in SIZES namelist' PPTOANC1.2378
write(6,*)'len1_rowdepc should equal rows in levels dataset' PPTOANC1.2379
write(6,*)'resubmit' PPTOANC1.2380
icode = 222 PPTOANC1.2381
go to 9999 ! Jump out PPTOANC1.2382
end if PPTOANC1.2383
PPTOANC1.2384
if (len1_coldepc .ne. columns+2) then PPTOANC1.2385
write(6,*)'wrong number of columns in SIZES namelist' PPTOANC1.2386
write(6,*)'len1_coldepc should equal columns+2 in PPTOANC1.2387
& levels dataset' PPTOANC1.2388
write(6,*)'resubmit' PPTOANC1.2389
icode = 223 PPTOANC1.2390
go to 9999 ! Jump out PPTOANC1.2391
end if PPTOANC1.2392
PPTOANC1.2393
if (len1_coldepc*len1_rowdepc .ne. len1_flddepc) then PPTOANC1.2394
write(6,*)'len1_flddepc should equal PPTOANC1.2395
& len1_coldepc*len1_rowdepc' PPTOANC1.2396
write(6,*)'resubmit' PPTOANC1.2397
icode = 224 PPTOANC1.2398
go to 9999 ! Jump out PPTOANC1.2399
end if PPTOANC1.2400
PPTOANC1.2401
do j = 1,rows PPTOANC1.2402
do i = 1,columns PPTOANC1.2403
temp_levels_array(i,j) = levels_array(i,j) PPTOANC1.2404
enddo PPTOANC1.2405
enddo PPTOANC1.2406
PPTOANC1.2407
do j = 1,rows PPTOANC1.2408
temp_levels_array(columns+1,j)=temp_levels_array(1,j) PPTOANC1.2409
temp_levels_array(columns+2,j)=temp_levels_array(2,j) PPTOANC1.2410
enddo PPTOANC1.2411
PPTOANC1.2412
do j = 1,rows PPTOANC1.2413
do i = 1,len1_coldepc PPTOANC1.2414
fields_const(i+(j-1)*len1_coldepc,1) = temp_levels_array(i,j) PPTOANC1.2415
enddo PPTOANC1.2416
enddo PPTOANC1.2417
PPTOANC1.2418
else PPTOANC1.2419
PPTOANC1.2420
if (len1_rowdepc .ne. rows) then PPTOANC1.2421
write(6,*)'wrong number of rows in SIZES namelist' PPTOANC1.2422
write(6,*)'len1_rowdepc should equal rows in levels dataset' PPTOANC1.2423
write(6,*)'resubmit' PPTOANC1.2424
icode = 222 PPTOANC1.2425
go to 9999 ! Jump out PPTOANC1.2426
end if PPTOANC1.2427
PPTOANC1.2428
if (len1_coldepc .ne. columns) then PPTOANC1.2429
write(6,*)'wrong number of columns in SIZES namelist' PPTOANC1.2430
write(6,*)'len1_coldepc should equal columns in PPTOANC1.2431
& levels dataset' PPTOANC1.2432
write(6,*)'resubmit' PPTOANC1.2433
icode = 223 PPTOANC1.2434
go to 9999 ! Jump out PPTOANC1.2435
end if PPTOANC1.2436
PPTOANC1.2437
if (len1_coldepc*len1_rowdepc .ne. len1_flddepc) then PPTOANC1.2438
write(6,*)'len1_flddepc should equal PPTOANC1.2439
& len1_coldepc*len1_rowdepc' PPTOANC1.2440
write(6,*)'resubmit' PPTOANC1.2441
icode = 224 PPTOANC1.2442
go to 9999 ! Jump out PPTOANC1.2443
end if PPTOANC1.2444
PPTOANC1.2445
do j = 1,rows PPTOANC1.2446
do i = 1,len1_coldepc PPTOANC1.2447
fields_const(i+(j-1)*len1_coldepc,1) = levels_array(i,j) PPTOANC1.2448
enddo PPTOANC1.2449
enddo PPTOANC1.2450
PPTOANC1.2451
end if PPTOANC1.2452
PPTOANC1.2453
CL 2.1 Initialise cfi3 array and create the compression indices. PPTOANC1.2454
PPTOANC1.2455
if (compress) then PPTOANC1.2456
PPTOANC1.2457
do 20,k=1,nlevels PPTOANC1.2458
do 10,j=1,rows PPTOANC1.2459
cfi3(j,k)=imdi PPTOANC1.2460
PPTOANC1.2461
10 continue PPTOANC1.2462
20 continue PPTOANC1.2463
PPTOANC1.2464
count=0 PPTOANC1.2465
seg_count=0 PPTOANC1.2466
PPTOANC1.2467
do 50,k=1,nlevels PPTOANC1.2468
do 40,j=1,rows PPTOANC1.2469
c PPTOANC1.2470
c if the first element in a row is sea, a new segment is starting, PPTOANC1.2471
c so count and seg_count are both incremented, and cfi1 and PPTOANC1.2472
c cfi2 have new entries. Columns is used here instead of PPTOANC1.2473
c len1_coldepc as the index to this array expects that in oa_pack. PPTOANC1.2474
c PPTOANC1.2475
if (k.le.levels_array(1,j)) then PPTOANC1.2476
count=count+1 PPTOANC1.2477
seg_count=seg_count+1 PPTOANC1.2478
cfi1(seg_count)=count PPTOANC1.2479
cfi2(seg_count)=1+(j-1)*columns+(k-1)*columns*rows PPTOANC1.2480
cfi3(j,k)=seg_count PPTOANC1.2481
end if PPTOANC1.2482
PPTOANC1.2483
do 30,i=2,columns PPTOANC1.2484
c PPTOANC1.2485
c if present point is sea, add one to count PPTOANC1.2486
c PPTOANC1.2487
if (k.le.levels_array(i,j)) then PPTOANC1.2488
count=count+1 PPTOANC1.2489
end if PPTOANC1.2490
c PPTOANC1.2491
c if present point is sea and previous point is land, PPTOANC1.2492
c a new segment is starting, so seg_count is incremented PPTOANC1.2493
c and cfi1 and cfi2 have new entries. Columns is used here instead PPTOANC1.2494
c of len1_coldepc as the index to this array expects that PPTOANC1.2495
c in oa_pack. PPTOANC1.2496
c PPTOANC1.2497
if ((k.gt.levels_array(i-1,j)).and. PPTOANC1.2498
& (k.le.levels_array(i,j))) then PPTOANC1.2499
seg_count=seg_count+1 PPTOANC1.2500
cfi1(seg_count)=count PPTOANC1.2501
cfi2(seg_count)=i+(j-1)*columns+(k-1)*columns*rows PPTOANC1.2502
c PPTOANC1.2503
c if cfi3(j,k) has not been reset, PPTOANC1.2504
c then the present segment must be the first in the row PPTOANC1.2505
c PPTOANC1.2506
if (cfi3(j,k).eq.imdi) then PPTOANC1.2507
cfi3(j,k)=seg_count PPTOANC1.2508
end if PPTOANC1.2509
end if PPTOANC1.2510
30 continue PPTOANC1.2511
PPTOANC1.2512
c PPTOANC1.2513
c if there is no sea segment in the row, PPTOANC1.2514
c then set cfi3 to seg_count+1 PPTOANC1.2515
c PPTOANC1.2516
if (cfi3(j,k).eq.imdi) then PPTOANC1.2517
cfi3(j,k)=seg_count+1 PPTOANC1.2518
end if PPTOANC1.2519
PPTOANC1.2520
40 continue PPTOANC1.2521
50 continue PPTOANC1.2522
PPTOANC1.2523
end if PPTOANC1.2524
9999 continue PPTOANC1.2525
return PPTOANC1.2526
end PPTOANC1.2527
! PPTOANC1.2528
! Subroutine interface: PPTOANC1.2529
subroutine calc_len_cfi(ftin2,cols_nowrap,len1_rowdepc, 1,1PPTOANC1.2530
& nlevels,len_cfi,fldsizelev,ibm_to_cray, PPTOANC1.2531
& add_wrap_pts,icode) PPTOANC1.2532
PPTOANC1.2533
implicit none PPTOANC1.2534
! PPTOANC1.2535
! Description: PPTOANC1.2536
! this subroutine calculates the dimensions of the PPTOANC1.2537
! compression arrays. It is a subset of the subroutine PPTOANC1.2538
! calc_cfi_and_fld PPTOANC1.2539
! PPTOANC1.2540
! Method: PPTOANC1.2541
! PPTOANC1.2542
! Current Code Owner: D Robinson / I Edmond PPTOANC1.2543
! PPTOANC1.2544
! History: PPTOANC1.2545
! Version Date Comment PPTOANC1.2546
! ------- ---- ------- PPTOANC1.2547
! 19/12/96 Original code. Catherine Jones PPTOANC1.2548
! 4.4 14/8/97 Consolidated in UM Ian Edmond PPTOANC1.2549
! PPTOANC1.2550
! Code Description: PPTOANC1.2551
! Language: FORTRAN 77 + common extensions. PPTOANC1.2552
! This code is written to UMDP3 v6 programming standards. PPTOANC1.2553
! PPTOANC1.2554
! Declarations: PPTOANC1.2555
! These are of the form:- PPTOANC1.2556
! INTEGER ExampleVariable !Description of variable PPTOANC1.2557
! PPTOANC1.2558
! Subroutine arguments PPTOANC1.2559
! Scalar arguments with intent(in): PPTOANC1.2560
PPTOANC1.2561
integer ftin2 ! (in) unit number for levels dataset PPTOANC1.2562
integer cols_nowrap ! (in) number of points east-west PPTOANC1.2563
! (without wrap points) PPTOANC1.2564
integer len1_rowdepc ! (in) number of points north-south PPTOANC1.2565
integer nlevels ! (in) number of points in vertical PPTOANC1.2566
PPTOANC1.2567
PPTOANC1.2568
logical ibm_to_cray ! T => input pp data is in IBM number PPTOANC1.2569
! format and needs to be converted to PPTOANC1.2570
! run on the Cray. PPTOANC1.2571
logical add_wrap_pts ! T => add wrap points to the output file PPTOANC1.2572
PPTOANC1.2573
character*80 levels PPTOANC1.2574
PPTOANC1.2575
integer icode ! error code PPTOANC1.2576
PPTOANC1.2577
! Array arguments with intent(in): PPTOANC1.2578
PPTOANC1.2579
integer len_cfi(3) ! (out) total number of sea segments PPTOANC1.2580
integer fldsizelev(nlevels) !(out) no. of points on each level PPTOANC1.2581
! of compressed field PPTOANC1.2582
PPTOANC1.2583
PPTOANC1.2584
! Local Scalars PPTOANC1.2585
PPTOANC1.2586
integer columns ! no. of columns in levels dataset PPTOANC1.2587
integer rows ! no. of rows in levels dataset PPTOANC1.2588
integer i,j,k ! local loop indices PPTOANC1.2589
integer ierr ! return code from ibm2cri PPTOANC1.2590
integer count ! local counter for points in a sea segment PPTOANC1.2591
integer seg_count ! local counter for number of sea segments PPTOANC1.2592
integer last_count ! local counter for calcultaing points in a PPTOANC1.2593
! sea segment PPTOANC1.2594
! Local dynamic arrays: PPTOANC1.2595
PPTOANC1.2596
integer pp_int(45) ! integer part of levels lookup header PPTOANC1.2597
real pp_real(19) ! real part of levels lookup header PPTOANC1.2598
PPTOANC1.2599
real*4 levels_in(cols_nowrap*len1_rowdepc) PPTOANC1.2600
! temp array for levels dataset to be PPTOANC1.2601
! converted to cray number format PPTOANC1.2602
real levels_array(cols_nowrap,len1_rowdepc) PPTOANC1.2603
! array of ocean levels PPTOANC1.2604
PPTOANC1.2605
! Function & Subroutine calls: PPTOANC1.2606
integer ibm2cri PPTOANC1.2607
PPTOANC1.2608
!- End of header PPTOANC1.2609
PPTOANC1.2610
CL 1. Take required dimensions from levels dataset PPTOANC1.2611
PPTOANC1.2612
CL 1.2 Obtain columns and rows by reading header PPTOANC1.2613
PPTOANC1.2614
call read_pp_header(ftin2,pp_int,pp_real,ibm_to_cray) PPTOANC1.2615
PPTOANC1.2616
rows = pp_int(18) PPTOANC1.2617
columns = pp_int(19) PPTOANC1.2618
PPTOANC1.2619
print*,'rows = ',rows PPTOANC1.2620
print*,'columns = ',columns PPTOANC1.2621
PPTOANC1.2622
CL 1.3 Check the dimensions and read the levels_array. PPTOANC1.2623
PPTOANC1.2624
if (len1_rowdepc .ne. rows) then PPTOANC1.2625
write(6,*)'wrong number of rows in SIZES namelist' PPTOANC1.2626
write(6,*)'len1_rowdepc should equal rows in levels dataset' PPTOANC1.2627
write(6,*)'resubmit' PPTOANC1.2628
icode = 222 PPTOANC1.2629
go to 9999 ! Jump out PPTOANC1.2630
end if PPTOANC1.2631
PPTOANC1.2632
if (cols_nowrap .ne. columns) then PPTOANC1.2633
write(6,*)'wrong number of columns in SIZES namelist' PPTOANC1.2634
write(6,*)'len1_coldepc should equal columns in levels dataset' PPTOANC1.2635
write(6,*)'resubmit' PPTOANC1.2636
icode = 223 PPTOANC1.2637
go to 9999 ! Jump out PPTOANC1.2638
end if PPTOANC1.2639
PPTOANC1.2640
CL Do number conversion if required PPTOANC1.2641
PPTOANC1.2642
if (ibm_to_cray) then PPTOANC1.2643
read(ftin2) levels_in PPTOANC1.2644
ierr=ibm2cri(3,rows*columns,levels_in,0,levels_array,1,64,32) PPTOANC1.2645
else PPTOANC1.2646
read(ftin2)levels_array PPTOANC1.2647
end if PPTOANC1.2648
PPTOANC1.2649
close(ftin2) PPTOANC1.2650
PPTOANC1.2651
CL 2. Calculate len_cfi and fldsizelev PPTOANC1.2652
PPTOANC1.2653
CL 2.1 Loop over the points in the field to calculate the number of PPTOANC1.2654
CL segments PPTOANC1.2655
PPTOANC1.2656
count=0 PPTOANC1.2657
seg_count=0 PPTOANC1.2658
last_count=0 PPTOANC1.2659
PPTOANC1.2660
do 50,k=1,nlevels PPTOANC1.2661
do 40,j=1,rows PPTOANC1.2662
PPTOANC1.2663
if (k .le. levels_array(1,j)) then PPTOANC1.2664
count = count + 1 PPTOANC1.2665
seg_count = seg_count + 1 PPTOANC1.2666
end if PPTOANC1.2667
PPTOANC1.2668
do 30,i=2,cols_nowrap PPTOANC1.2669
PPTOANC1.2670
if (k .le. levels_array(i,j)) then PPTOANC1.2671
count = count + 1 PPTOANC1.2672
end if PPTOANC1.2673
PPTOANC1.2674
if ((k .gt. levels_array(i-1,j)) .and. PPTOANC1.2675
& (k.le.levels_array(i,j))) then PPTOANC1.2676
seg_count=seg_count+1 PPTOANC1.2677
end if PPTOANC1.2678
PPTOANC1.2679
30 continue PPTOANC1.2680
40 continue PPTOANC1.2681
PPTOANC1.2682
fldsizelev(k) = count - last_count PPTOANC1.2683
print*,'k = ',k PPTOANC1.2684
print*,'fldsizelev(k) = ',fldsizelev(k) PPTOANC1.2685
PPTOANC1.2686
last_count = count PPTOANC1.2687
PPTOANC1.2688
50 continue PPTOANC1.2689
PPTOANC1.2690
len_cfi(1) = seg_count PPTOANC1.2691
len_cfi(2) = seg_count PPTOANC1.2692
len_cfi(3) = rows * nlevels PPTOANC1.2693
PPTOANC1.2694
print*,'len_cfi(1) = ',len_cfi(1) PPTOANC1.2695
print*,'len_cfi(2) = ',len_cfi(2) PPTOANC1.2696
print*,'len_cfi(3) = ',len_cfi(3) PPTOANC1.2697
PPTOANC1.2698
PPTOANC1.2699
9999 continue PPTOANC1.2700
return PPTOANC1.2701
end PPTOANC1.2702
! PPTOANC1.2703
! Subroutine interface: PPTOANC1.2704
subroutine conv_real(rlookup,lookup_all,len2_lookup) 1PPTOANC1.2705
PPTOANC1.2706
implicit none PPTOANC1.2707
! PPTOANC1.2708
! Description: PPTOANC1.2709
! Convert's the real part of the lookup header (rlookup) PPTOANC1.2710
! into integer's so that it can be represented as one PPTOANC1.2711
! array(lookup_all) PPTOANC1.2712
! PPTOANC1.2713
! Method: PPTOANC1.2714
! PPTOANC1.2715
! Current Code Owner: D Robinson / I Edmond PPTOANC1.2716
! PPTOANC1.2717
! History: PPTOANC1.2718
! Version Date Comment PPTOANC1.2719
! ------- ---- ------- PPTOANC1.2720
! 05/12/96 Original code. Catherine Jones PPTOANC1.2721
! 4.4 14/8/97 Consolidated in UM Ian Edmond PPTOANC1.2722
! PPTOANC1.2723
! Code Description: PPTOANC1.2724
! Language: FORTRAN 77 + common extensions. PPTOANC1.2725
! This code is written to UMDP3 v6 programming standards. PPTOANC1.2726
! PPTOANC1.2727
! PPTOANC1.2728
! Declarations: PPTOANC1.2729
! These are of the form:- PPTOANC1.2730
! INTEGER ExampleVariable !Description of variable PPTOANC1.2731
! PPTOANC1.2732
PPTOANC1.2733
! Subroutine arguments PPTOANC1.2734
! Scalar arguments with intent(in): PPTOANC1.2735
integer len2_lookup !IN no. of fields PPTOANC1.2736
PPTOANC1.2737
! Array arguments with intent(in): PPTOANC1.2738
real rlookup(19,len2_lookup) !IN real part of lookup table PPTOANC1.2739
PPTOANC1.2740
! Array arguments with intent(out): PPTOANC1.2741
real lookup_all(64,len2_lookup) !OUT whole lookup table PPTOANC1.2742
PPTOANC1.2743
! Local scalar PPTOANC1.2744
integer i ! loop counter PPTOANC1.2745
PPTOANC1.2746
!- End of header PPTOANC1.2747
PPTOANC1.2748
do i = 1,len2_lookup PPTOANC1.2749
lookup_all(46:64,i) = rlookup(1:19,i) PPTOANC1.2750
enddo PPTOANC1.2751
PPTOANC1.2752
return PPTOANC1.2753
end PPTOANC1.2754
! PPTOANC1.2755
! Subroutine interface: PPTOANC1.2756
subroutine dataw(rows,columns,fieldsize,nlevels,levn,len_extra, 1,5PPTOANC1.2757
& fieldn,len1_lookup_all,lookup_all,fixhd, PPTOANC1.2758
& len_cfi, cfi1, cfi2, cfi3, fldsizelev,ftin1,ftout, PPTOANC1.2759
& tracer_grid,add_wrap_pts,ibm_to_cray,compress,rmdi_input,wave, PPTOANC1.2760
& lsmask, PPTOANC1.2761
*CALL ARGPPX PPTOANC1.2762
& icode) PPTOANC1.2763
PPTOANC1.2764
implicit none PPTOANC1.2765
PPTOANC1.2766
! PPTOANC1.2767
! Description: This writes the data out using WRITFLD. PPTOANC1.2768
! If compress oa_pack is used. PPTOANC1.2769
! PPTOANC1.2770
! Method: PPTOANC1.2771
! PPTOANC1.2772
! Current Code Owner: D Robinson / I Edmond PPTOANC1.2773
! PPTOANC1.2774
! History: PPTOANC1.2775
! Version Date Comment PPTOANC1.2776
! ------- ---- ------- PPTOANC1.2777
! 16/06/94 Original code. Dave Robinson PPTOANC1.2778
! 4.4 14/8/97 Consolidated in UM Ian Edmond PPTOANC1.2779
! PPTOANC1.2780
! Code Description: PPTOANC1.2781
! Language: FORTRAN 77 + common extensions. PPTOANC1.2782
! This code is written to UMDP3 v6 programming standards. PPTOANC1.2783
! PPTOANC1.2784
! Declarations: PPTOANC1.2785
! These are of the form:- PPTOANC1.2786
! INTEGER ExampleVariable !Description of variable PPTOANC1.2787
! 1.0 Global variables (*CALLed COMDECKs etc...): PPTOANC1.2788
*CALL CSUBMODL PPTOANC1.2789
*CALL CPPXREF PPTOANC1.2790
*CALL PPXLOOK PPTOANC1.2791
*CALL C_MDI PPTOANC1.2792
PPTOANC1.2793
! Subroutine arguments PPTOANC1.2794
! Scalar arguments with intent(in): PPTOANC1.2795
PPTOANC1.2796
integer rows ! number of rows in input pp field PPTOANC1.2797
integer columns ! number of columns in input pp field PPTOANC1.2798
integer fieldsize ! number of points in output anc. field PPTOANC1.2799
integer nlevels ! number of levels PPTOANC1.2800
integer levn ! current level number PPTOANC1.2801
integer len_extra PPTOANC1.2802
integer ftin1 PPTOANC1.2803
integer ftout PPTOANC1.2804
integer fieldn PPTOANC1.2805
integer len1_lookup_all PPTOANC1.2806
integer icode ! error status PPTOANC1.2807
PPTOANC1.2808
real rmdi_input PPTOANC1.2809
PPTOANC1.2810
logical tracer_grid PPTOANC1.2811
logical add_wrap_pts PPTOANC1.2812
logical ibm_to_cray PPTOANC1.2813
logical compress PPTOANC1.2814
PPTOANC1.2815
! Array arguments with intent(in): PPTOANC1.2816
PPTOANC1.2817
integer lookup_all(len1_lookup_all,*) PPTOANC1.2818
integer fixhd(*) PPTOANC1.2819
PPTOANC1.2820
integer len_cfi(3) ! dimensions of arrays PPTOANC1.2821
integer cfi1(len_cfi(1)) ! compressed PPTOANC1.2822
integer cfi2(len_cfi(2)) ! field index PPTOANC1.2823
integer cfi3(len_cfi(3)) ! arrays PPTOANC1.2824
integer fldsizelev(nlevels) ! size of output field on each level PPTOANC1.2825
PPTOANC1.2826
logical lsmask(rows*columns) PPTOANC1.2827
PPTOANC1.2828
C local arrays PPTOANC1.2829
real*4 datain(rows*columns) PPTOANC1.2830
real data_field(rows*columns) PPTOANC1.2831
real field_wrap(columns+2,rows) PPTOANC1.2832
real field_to_write(fieldsize) PPTOANC1.2833
real extra_data(len_extra+1) ! space for extra data PPTOANC1.2834
PPTOANC1.2835
! Local Scalars PPTOANC1.2836
integer i PPTOANC1.2837
integer j,istart,iend,ii PPTOANC1.2838
integer field_type ! 0 for tracers; 1 for velocities PPTOANC1.2839
integer ierr ! error status from ibm2cri PPTOANC1.2840
integer no_cmp ! # of pts in full compressed field (all levels) PPTOANC1.2841
integer no_rows_m ! number of rows east-west on model grid PPTOANC1.2842
integer n_sea_points PPTOANC1.2843
PPTOANC1.2844
logical LTimer ! timer switch (set to false) PPTOANC1.2845
logical cyclic_grid ! T => input field to OA_PACK has PPTOANC1.2846
! overlap points PPTOANC1.2847
logical wave ! creating wave dump PPTOANC1.2848
PPTOANC1.2849
character*256 cmessage ! error message PPTOANC1.2850
PPTOANC1.2851
PPTOANC1.2852
PPTOANC1.2853
! Function & Subroutine calls: PPTOANC1.2854
INTEGER IBM2CRI PPTOANC1.2855
REAL P1,P2 PPTOANC1.2856
LOGICAL LNER PPTOANC1.2857
LNER(P1,P2) = ((ABS(P1-P2)) .LT. (1.E-6*ABS(P1+P2))) PPTOANC1.2858
PPTOANC1.2859
!- End of header PPTOANC1.2860
PPTOANC1.2861
PPTOANC1.2862
CL 1. Read data and do number format conversion if needed PPTOANC1.2863
if (ibm_to_cray) then PPTOANC1.2864
read(ftin1) datain PPTOANC1.2865
ierr=ibm2cri(3,rows*columns,datain,0,data_field,1,64,32) PPTOANC1.2866
else PPTOANC1.2867
read(ftin1) data_field,(extra_data(i),i=1,len_extra) PPTOANC1.2868
end if PPTOANC1.2869
PPTOANC1.2870
PPTOANC1.2871
CL 1.1 Convert real missing data indicators PPTOANC1.2872
if ( rmdi_input .ne. rmdi) then PPTOANC1.2873
i=0 PPTOANC1.2874
do j = 1,rows*columns PPTOANC1.2875
if ( LNER (data_field(j), rmdi_input) ) then PPTOANC1.2876
! if ( rmdi_input .gt. 0.0 ) then PPTOANC1.2877
data_field(j) = rmdi PPTOANC1.2878
i=i+1 PPTOANC1.2879
end if PPTOANC1.2880
end do PPTOANC1.2881
if (i.gt.0) then PPTOANC1.2882
write (6,*) i,' RMDI converted from ',rmdi_input,' to ',rmdi PPTOANC1.2883
endif PPTOANC1.2884
end if PPTOANC1.2885
PPTOANC1.2886
CL 2. Add in wrap points when add_wrap_pts=t PPTOANC1.2887
PPTOANC1.2888
if (add_wrap_pts) then PPTOANC1.2889
PPTOANC1.2890
do 20,j=1,rows PPTOANC1.2891
do 10,i=1,columns PPTOANC1.2892
field_wrap(i,j)=data_field(i+(j-1)*columns) PPTOANC1.2893
10 continue PPTOANC1.2894
20 continue PPTOANC1.2895
PPTOANC1.2896
do 30,j=1,rows PPTOANC1.2897
field_wrap(columns+1,j)=field_wrap(1,j) PPTOANC1.2898
field_wrap(columns+2,j)=field_wrap(2,j) PPTOANC1.2899
30 continue PPTOANC1.2900
PPTOANC1.2901
CL 3. Pack data using compression indices when compress=t PPTOANC1.2902
PPTOANC1.2903
if (compress) then PPTOANC1.2904
PPTOANC1.2905
if(.not.wave) then PPTOANC1.2906
PPTOANC1.2907
if (tracer_grid) then PPTOANC1.2908
field_type = 0 PPTOANC1.2909
no_rows_m = rows PPTOANC1.2910
else PPTOANC1.2911
field_type = 1 PPTOANC1.2912
no_rows_m = rows + 1 PPTOANC1.2913
end if PPTOANC1.2914
PPTOANC1.2915
no_cmp = 0 PPTOANC1.2916
do i = 1, nlevels ! do not use levn in this loop PPTOANC1.2917
no_cmp = no_cmp + fldsizelev(i) PPTOANC1.2918
end do PPTOANC1.2919
PPTOANC1.2920
cyclic_grid = .TRUE. ! input pp fields do not PPTOANC1.2921
! have wrap-points PPTOANC1.2922
PPTOANC1.2923
LTimer = .FALSE. PPTOANC1.2924
icode = 0 PPTOANC1.2925
PPTOANC1.2926
call OA_PACK(icode, cmessage, LTimer, PPTOANC1.2927
# no_rows_m, columns+2, nlevels, len_cfi(1), fieldsize, PPTOANC1.2928
# cfi1, cfi2, cfi3, no_cmp, rmdi, PPTOANC1.2929
# levn, field_type, cyclic_grid, field_wrap, PPTOANC1.2930
# field_to_write) PPTOANC1.2931
PPTOANC1.2932
PPTOANC1.2933
if (icode .GT. 0) then PPTOANC1.2934
write (6,*) 'error from OA_PACK:', cmessage PPTOANC1.2935
go to 9999 PPTOANC1.2936
end if PPTOANC1.2937
PPTOANC1.2938
else ! add_wrap .and. compress .and. wave PPTOANC1.2939
PPTOANC1.2940
C compress using SLMASK for wave model - use SEA POINTS set to TRUE PPTOANC1.2941
C a value for n-SEA-points is returned from this subroutine PPTOANC1.2942
PPTOANC1.2943
!!!!!!!!! This needs attention PPTOANC1.2944
PPTOANC1.2945
CALL to_land_points(data_field,field_to_write,lsmask, PPTOANC1.2946
+ rows*columns,n_SEA_points) PPTOANC1.2947
PPTOANC1.2948
print*,'after to land points no_cmp is ',n_sea_points PPTOANC1.2949
no_cmp=n_sea_points PPTOANC1.2950
PPTOANC1.2951
endif PPTOANC1.2952
PPTOANC1.2953
else ! add_wrap .and. .not. compress PPTOANC1.2954
PPTOANC1.2955
do 50,j=1,rows PPTOANC1.2956
do 40,i=1,columns+2 PPTOANC1.2957
field_to_write(i+(j-1)*(columns+2) ) = field_wrap(i,j) PPTOANC1.2958
40 continue PPTOANC1.2959
50 continue PPTOANC1.2960
PPTOANC1.2961
endif PPTOANC1.2962
PPTOANC1.2963
else ! .not. add_wrap PPTOANC1.2964
PPTOANC1.2965
CL 3.1 Pack data using compression indices when compress=t PPTOANC1.2966
PPTOANC1.2967
if (compress) then PPTOANC1.2968
PPTOANC1.2969
if(.not. wave) then PPTOANC1.2970
PPTOANC1.2971
if (tracer_grid) then PPTOANC1.2972
field_type = 0 PPTOANC1.2973
no_rows_m = rows PPTOANC1.2974
else PPTOANC1.2975
field_type = 1 PPTOANC1.2976
no_rows_m = rows + 1 PPTOANC1.2977
end if PPTOANC1.2978
PPTOANC1.2979
no_cmp = 0 PPTOANC1.2980
do i = 1, nlevels ! do not use levn in this loop PPTOANC1.2981
no_cmp = no_cmp + fldsizelev(i) PPTOANC1.2982
end do PPTOANC1.2983
PPTOANC1.2984
cyclic_grid = .FALSE. ! input pp fields do not PPTOANC1.2985
! have wrap-points PPTOANC1.2986
PPTOANC1.2987
LTimer = .FALSE. PPTOANC1.2988
icode = 0 PPTOANC1.2989
PPTOANC1.2990
call OA_PACK(icode, cmessage, LTimer, PPTOANC1.2991
# no_rows_m, columns, nlevels, len_cfi(1), fieldsize, PPTOANC1.2992
# cfi1, cfi2, cfi3, no_cmp, rmdi, PPTOANC1.2993
# levn, field_type, cyclic_grid, data_field, field_to_write) PPTOANC1.2994
PPTOANC1.2995
PPTOANC1.2996
if (icode .GT. 0) then PPTOANC1.2997
write (6,*) 'error from OA_PACK:', cmessage PPTOANC1.2998
go to 9999 PPTOANC1.2999
end if PPTOANC1.3000
PPTOANC1.3001
else ! .not. add_wrap .and. compress .and. wave PPTOANC1.3002
PPTOANC1.3003
C compress using SLMASK for wave model - use SEA POINTS set to TRUE PPTOANC1.3004
C a value for n-SEA-points is returned from this subroutine PPTOANC1.3005
PPTOANC1.3006
CALL to_land_points(data_field,field_to_write,lsmask, PPTOANC1.3007
+ rows*columns,n_SEA_points) PPTOANC1.3008
PPTOANC1.3009
print*,'after to land points no_cmp is ',n_sea_points PPTOANC1.3010
no_cmp=n_sea_points PPTOANC1.3011
PPTOANC1.3012
endif PPTOANC1.3013
PPTOANC1.3014
else ! .not. add_wrap .and. .not. compress PPTOANC1.3015
PPTOANC1.3016
do j = 1, fieldsize PPTOANC1.3017
field_to_write(j) = data_field(j) PPTOANC1.3018
end do PPTOANC1.3019
PPTOANC1.3020
endif PPTOANC1.3021
PPTOANC1.3022
end if PPTOANC1.3023
PPTOANC1.3024
CL 5. Output data using WRITFLDS PPTOANC1.3025
PPTOANC1.3026
CC TEMP print out data LSMASK for wave dump PPTOANC1.3027
PPTOANC1.3028
if(lookup_all(23,fieldn).eq.38) then PPTOANC1.3029
write(6,*) ' ' PPTOANC1.3030
print*,'before writing data array' PPTOANC1.3031
istart=1 PPTOANC1.3032
iend=istart+columns-1 PPTOANC1.3033
do i=rows,1,-1 PPTOANC1.3034
print*, (field_to_write(ii),ii=istart,iend) PPTOANC1.3035
istart=istart+columns PPTOANC1.3036
iend=iend+columns PPTOANC1.3037
enddo PPTOANC1.3038
endif PPTOANC1.3039
PPTOANC1.3040
CALL WRITFLDS(ftout,1,fieldn,lookup_all, PPTOANC1.3041
# len1_lookup_all,field_to_write,fieldsize, PPTOANC1.3042
# fixhd, PPTOANC1.3043
*CALL ARGPPX PPTOANC1.3044
# icode,cmessage ) PPTOANC1.3045
PPTOANC1.3046
if (icode .GT. 0) then PPTOANC1.3047
write (6,*) 'error from WRITFLDS:', cmessage PPTOANC1.3048
go to 9999 PPTOANC1.3049
end if PPTOANC1.3050
PPTOANC1.3051
9999 continue PPTOANC1.3052
return PPTOANC1.3053
end PPTOANC1.3054
c Purpose: Works out the lookup tables for the dump/ancillary * PPTOANC1.3055
c file header from the pp fields * PPTOANC1.3056
! PPTOANC1.3057
! Subroutine interface: PPTOANC1.3058
subroutine pp_table(pp_int,pp_real,nfields,lookup,rlookup, 1PPTOANC1.3059
# fieldsize,n,levn,m,runtot,number_of_codes,field_code, PPTOANC1.3060
# stash_code,add_wrap_pts,compress,pack32,wave,len1_levdepc, PPTOANC1.3061
# len2_levdepc,lev_dep_consts,len_realc,real_const,icode) PPTOANC1.3062
PPTOANC1.3063
implicit none PPTOANC1.3064
! PPTOANC1.3065
! Description: PPTOANC1.3066
! Works out the lookup tables for the dump/ancillary PPTOANC1.3067
! file header from the pp fields PPTOANC1.3068
! PPTOANC1.3069
! Method: PPTOANC1.3070
! PPTOANC1.3071
! Current Code Owner: D Robinson / I Edmond PPTOANC1.3072
! PPTOANC1.3073
! History: PPTOANC1.3074
! Version Date Comment PPTOANC1.3075
! ------- ---- ------- PPTOANC1.3076
! 16/06/94 Original code. Dave Robinson PPTOANC1.3077
! 4.4 14/8/97 Consolidated in UM Ian Edmond PPTOANC1.3078
! PPTOANC1.3079
! Code Description: PPTOANC1.3080
! Language: FORTRAN 77 + common extensions. PPTOANC1.3081
! This code is written to UMDP3 v6 programming standards. PPTOANC1.3082
! PPTOANC1.3083
! PPTOANC1.3084
! Declarations: PPTOANC1.3085
! These are of the form:- PPTOANC1.3086
! INTEGER ExampleVariable !Description of variable PPTOANC1.3087
! 1.0 Global variables (*CALLed COMDECKs etc...): PPTOANC1.3088
*CALL C_MDI PPTOANC1.3089
*CALL CLOOKADD PPTOANC1.3090
PPTOANC1.3091
! Subroutine arguments PPTOANC1.3092
! Scalar arguments with intent(in): PPTOANC1.3093
PPTOANC1.3094
integer nfields ! dimension for lookup tables PPTOANC1.3095
PPTOANC1.3096
integer fieldsize ! size of field to be stored in anc file PPTOANC1.3097
integer n ! field number PPTOANC1.3098
integer levn ! level number PPTOANC1.3099
integer m ! field type PPTOANC1.3100
integer number_of_codes PPTOANC1.3101
integer len1_levdepc PPTOANC1.3102
integer len2_levdepc PPTOANC1.3103
integer len_realc PPTOANC1.3104
PPTOANC1.3105
logical add_wrap_pts PPTOANC1.3106
logical compress PPTOANC1.3107
logical pack32 PPTOANC1.3108
logical wave ! T for wave dump creation PPTOANC1.3109
PPTOANC1.3110
PPTOANC1.3111
! Array arguments with intent(in): PPTOANC1.3112
PPTOANC1.3113
integer pp_int(45) PPTOANC1.3114
real pp_real(19) PPTOANC1.3115
integer field_code(number_of_codes) !stash and field codes PPTOANC1.3116
integer stash_code(number_of_codes) !input by user PPTOANC1.3117
PPTOANC1.3118
PPTOANC1.3119
! Scalar arguments with intent(in/out): PPTOANC1.3120
integer runtot ! start address for this field on input and PPTOANC1.3121
! for next field on output PPTOANC1.3122
integer icode PPTOANC1.3123
PPTOANC1.3124
! Array arguments with intent(in/out): PPTOANC1.3125
PPTOANC1.3126
integer lookup(45,nfields) PPTOANC1.3127
real rlookup(46:64,nfields) PPTOANC1.3128
PPTOANC1.3129
real lev_dep_consts(1+len1_levdepc*len2_levdepc) PPTOANC1.3130
real real_const(len_realc) PPTOANC1.3131
PPTOANC1.3132
PPTOANC1.3133
! Local Scalars PPTOANC1.3134
integer i PPTOANC1.3135
PPTOANC1.3136
!- End of header PPTOANC1.3137
PPTOANC1.3138
do i=1,45 PPTOANC1.3139
lookup(i,n) = 0 PPTOANC1.3140
enddo PPTOANC1.3141
PPTOANC1.3142
do i=46,64 PPTOANC1.3143
rlookup(i,n) = 0.0 PPTOANC1.3144
enddo PPTOANC1.3145
PPTOANC1.3146
lookup(lbyr,n) = pp_int(1) ! lbyr PPTOANC1.3147
lookup(lbmon,n) = pp_int(2) ! lbmon PPTOANC1.3148
lookup(lbdat,n) = pp_int(3) ! lbdat PPTOANC1.3149
lookup(lbhr,n) = pp_int(4) ! lbhr PPTOANC1.3150
lookup(lbmin,n) = pp_int(5) ! lbmin PPTOANC1.3151
lookup(lbday,n) = pp_int(6) ! lbday PPTOANC1.3152
lookup(lbyrd,n) = pp_int(7) ! lbyrd PPTOANC1.3153
lookup(lbmond,n) = pp_int(8) ! lbmond PPTOANC1.3154
lookup(lbdatd,n) = pp_int(9) ! lbdatd PPTOANC1.3155
lookup(lbhrd,n) = pp_int(10) ! lbhrd PPTOANC1.3156
lookup(lbmind,n) = pp_int(11) ! lbmind PPTOANC1.3157
lookup(lbdayd,n) = pp_int(12) ! lbdayd PPTOANC1.3158
PPTOANC1.3159
lookup(lbtim,n) = pp_int(13) ! lbtim PPTOANC1.3160
lookup(lbft,n) = pp_int(14) ! lbft UDR3F405.229
lookup(lbcode,n) = pp_int(16) ! lbcode PPTOANC1.3161
lookup(lbhem,n) = pp_int(17) ! lbhem PPTOANC1.3162
PPTOANC1.3163
CL 1.0 Obtain rows and columns depending on compress and PPTOANC1.3164
CL add_wrap_pts. PPTOANC1.3165
PPTOANC1.3166
if (add_wrap_pts) then PPTOANC1.3167
if (compress) then PPTOANC1.3168
lookup(lbrow,n) = 0 ! no rows if data is compressed PPTOANC1.3169
lookup(lbnpt,n) = 0 ! no columns if data compressed PPTOANC1.3170
else PPTOANC1.3171
lookup(lbrow,n) = pp_int(18) ! lbrow PPTOANC1.3172
lookup(lbnpt,n) = pp_int(19)+2 ! lbnpt PPTOANC1.3173
end if PPTOANC1.3174
PPTOANC1.3175
else PPTOANC1.3176
PPTOANC1.3177
if (compress) then PPTOANC1.3178
lookup(lbrow,n) = 0 ! no rows if data is compressed PPTOANC1.3179
lookup(lbnpt,n) = 0 ! no columns if data compressed PPTOANC1.3180
else PPTOANC1.3181
lookup(lbrow,n) = pp_int(18) ! lbrow PPTOANC1.3182
lookup(lbnpt,n) = pp_int(19) ! lbnpt PPTOANC1.3183
end if PPTOANC1.3184
PPTOANC1.3185
endif PPTOANC1.3186
CL PPTOANC1.3187
if (compress) then PPTOANC1.3188
PPTOANC1.3189
if(.not. wave) then PPTOANC1.3190
PPTOANC1.3191
CC compression using CFI PPTOANC1.3192
lookup(lbpack,n) = 00110 ! compression PPTOANC1.3193
PPTOANC1.3194
else PPTOANC1.3195
PPTOANC1.3196
CC for wave dump compression using ls mask PPTOANC1.3197
lookup(lbpack,n) = 00220 ! compression to sea points PPTOANC1.3198
PPTOANC1.3199
endif PPTOANC1.3200
PPTOANC1.3201
else PPTOANC1.3202
lookup(lbpack,n) = 00000 ! no compression PPTOANC1.3203
end if PPTOANC1.3204
PPTOANC1.3205
if (pack32) then PPTOANC1.3206
lookup(lbpack,n) = lookup(lbpack,n) + 2 ! lbpack PPTOANC1.3207
end if PPTOANC1.3208
PPTOANC1.3209
lookup(lblrec,n) = fieldsize ! lblrec PPTOANC1.3210
lookup(lbext,n) = pp_int(20) ! lbext PPTOANC1.3211
lookup(lbrel,n) = 2 ! lbrel PPTOANC1.3212
lookup(lbfc,n) = pp_int(23) ! lbfc PPTOANC1.3213
lookup(lbproc,n) = pp_int(25) ! lbproc PPTOANC1.3214
lookup(lbvc,n) = pp_int(26) ! lbvc PPTOANC1.3215
lookup(lbegin,n) = runtot ! lbegin PPTOANC1.3216
PPTOANC1.3217
lookup(lblev,n) = levn ! lblev (level number) PPTOANC1.3218
PPTOANC1.3219
CMH for spectral wave energy the required value is already in pp-header PPTOANC1.3220
if(pp_int(23).eq.351) then PPTOANC1.3221
lookup(lblev,n) = pp_int(33) ! wave model freq number PPTOANC1.3222
lookup(44,n) = pp_int(44) ! wave model dir number PPTOANC1.3223
endif PPTOANC1.3224
PPTOANC1.3225
lookup(lbproj,n) = pp_int(lbproj) PPTOANC1.3226
lookup(lbtyp,n) = pp_int(lbtyp) PPTOANC1.3227
lookup(lblev,n) = pp_int(lblev) PPTOANC1.3228
PPTOANC1.3229
lookup(lbsrce,n) = 1111 ! lbsrce; indicate that elements PPTOANC1.3230
C 39-43 follow UM convention PPTOANC1.3231
lookup(data_type,n) = pp_int(data_type) ! data type PPTOANC1.3232
PPTOANC1.3233
if (lookup(data_type,n).lt.1 .or. lookup(data_type,n).gt.3) then PPTOANC1.3234
write (6,*) '********** WARNING ****************** ' PPTOANC1.3235
write (6,*) ' Data Type= ',lookup(data_type,n),' for field ',n, PPTOANC1.3236
& ' is not recognised.' PPTOANC1.3237
write (6,*) ' Either correct PP Header or set it through', PPTOANC1.3238
& ' the HEADER_DATA namelist.' PPTOANC1.3239
write (6,*) '********** WARNING ****************** ' PPTOANC1.3240
endif PPTOANC1.3241
PPTOANC1.3242
lookup(naddr,n) = runtot ! start address in data PPTOANC1.3243
lookup(item_code,n) = pp_int(item_code) PPTOANC1.3244
PPTOANC1.3245
lookup(model_code,n) = pp_int(model_code) ! sub model identifier PPTOANC1.3246
PPTOANC1.3247
write (6,*) 'Field No ',n,' PP Field Code = ',lookup(lbfc,n), PPTOANC1.3248
+ ' Stash Code = ',lookup(item_code,n) PPTOANC1.3249
PPTOANC1.3250
runtot=runtot+fieldsize PPTOANC1.3251
PPTOANC1.3252
rlookup(blev,n) = pp_real(52-45) ! blev / hybrid lev 'B' value PPTOANC1.3253
rlookup(brlev,n) = pp_real(53-45) ! brlev PPTOANC1.3254
rlookup(bhlev,n) = pp_real(54-45) ! bhlev / hybrid lev 'A' value PPTOANC1.3255
rlookup(bhrlev,n) = pp_real(55-45) ! bhrlev PPTOANC1.3256
rlookup(bplat,n) = pp_real(56-45) ! bplat PPTOANC1.3257
rlookup(bplon,n) = pp_real(57-45) ! bplon PPTOANC1.3258
rlookup(bgor,n) = pp_real(58-45) ! bgor PPTOANC1.3259
rlookup(bzy,n) = pp_real(59-45) ! bzy PPTOANC1.3260
rlookup(bdy,n) = pp_real(60-45) ! bdy PPTOANC1.3261
rlookup(bzx,n) = pp_real(61-45) ! bzx PPTOANC1.3262
rlookup(bdx,n) = pp_real(62-45) ! bdx PPTOANC1.3263
PPTOANC1.3264
rlookup(bmdi,n) = rmdi ! bmdi PPTOANC1.3265
rlookup(bmks,n) = pp_real(64-45) ! bmks PPTOANC1.3266
PPTOANC1.3267
C for spectral wave energy the required value is set from real_const PPTOANC1.3268
if(pp_int(23).eq.351) then PPTOANC1.3269
rlookup(blev,n) = lev_dep_consts(pp_int(33)) ! wave model freq PPTOANC1.3270
rlookup(bhlev,n)= (pp_int(44)-1)*real_const(13) ! direction PPTOANC1.3271
endif PPTOANC1.3272
PPTOANC1.3273
9999 continue PPTOANC1.3274
return PPTOANC1.3275
end PPTOANC1.3276
! PPTOANC1.3277
! Subroutine interface: PPTOANC1.3278
subroutine readdata(rows,columns,ftin1,ibm_to_cray,len_extra) 1PPTOANC1.3279
PPTOANC1.3280
implicit none PPTOANC1.3281
! PPTOANC1.3282
! Description: PPTOANC1.3283
! PPTOANC1.3284
! PPTOANC1.3285
! PPTOANC1.3286
! Method: PPTOANC1.3287
! PPTOANC1.3288
! Current Code Owner: I Edmond PPTOANC1.3289
! PPTOANC1.3290
! History: PPTOANC1.3291
! Version Date Comment PPTOANC1.3292
! ------- ---- ------- PPTOANC1.3293
! 16/06/94 Original code. Dave Robinson PPTOANC1.3294
! 4.4 14/8/97 Consolidated in UM Ian Edmond PPTOANC1.3295
! PPTOANC1.3296
! Code Description: PPTOANC1.3297
! Language: FORTRAN 77 + common extensions. PPTOANC1.3298
! This code is written to UMDP3 v6 programming standards. PPTOANC1.3299
! PPTOANC1.3300
! PPTOANC1.3301
! Declarations: PPTOANC1.3302
! These are of the form:- PPTOANC1.3303
! INTEGER ExampleVariable !Description of variable PPTOANC1.3304
! PPTOANC1.3305
! Subroutine arguments PPTOANC1.3306
! Scalar arguments with intent(in): PPTOANC1.3307
PPTOANC1.3308
integer rows PPTOANC1.3309
integer columns PPTOANC1.3310
integer ftin1 PPTOANC1.3311
logical ibm_to_cray PPTOANC1.3312
integer len_extra PPTOANC1.3313
PPTOANC1.3314
! Local scalars: PPTOANC1.3315
integer i PPTOANC1.3316
PPTOANC1.3317
! local arrays: PPTOANC1.3318
real field2(rows*columns) PPTOANC1.3319
real extra_data2(len_extra+1) PPTOANC1.3320
PPTOANC1.3321
real*4 extra_data1(len_extra) PPTOANC1.3322
real*4 field1(rows*columns) PPTOANC1.3323
PPTOANC1.3324
! End of header PPTOANC1.3325
PPTOANC1.3326
if (ibm_to_cray) then PPTOANC1.3327
if (len_extra.gt.0) then PPTOANC1.3328
read (ftin1) field1,(extra_data1(i),i=1,len_extra) PPTOANC1.3329
else PPTOANC1.3330
read (ftin1) field1 PPTOANC1.3331
endif PPTOANC1.3332
else PPTOANC1.3333
if (len_extra.gt.0) then PPTOANC1.3334
read (ftin1) field2,(extra_data2(i),i=1,len_extra) PPTOANC1.3335
else PPTOANC1.3336
read (ftin1) field2 PPTOANC1.3337
endif PPTOANC1.3338
end if PPTOANC1.3339
PPTOANC1.3340
return PPTOANC1.3341
end PPTOANC1.3342
! PPTOANC1.3343
! Subroutine interface: PPTOANC1.3344
subroutine read_pp_header (ftin1,pp_int,pp_real,ibm_to_cray) 6PPTOANC1.3345
PPTOANC1.3346
implicit none PPTOANC1.3347
! PPTOANC1.3348
! Description: This reads the pp headers PPTOANC1.3349
! PPTOANC1.3350
! Method: PPTOANC1.3351
! PPTOANC1.3352
! Current Code Owner: D Robinson / I Edmond PPTOANC1.3353
! PPTOANC1.3354
! History: PPTOANC1.3355
! Version Date Comment PPTOANC1.3356
! ------- ---- ------- PPTOANC1.3357
! 16/06/94 Original code. Dave Robinson PPTOANC1.3358
! 4.4 14/8/97 Consolidated in UM Ian Edmond PPTOANC1.3359
! PPTOANC1.3360
! Code Description: PPTOANC1.3361
! Language: FORTRAN 77 + common extensions. PPTOANC1.3362
! This code is written to UMDP3 v6 programming standards. PPTOANC1.3363
! PPTOANC1.3364
! PPTOANC1.3365
! Declarations: PPTOANC1.3366
! These are of the form:- PPTOANC1.3367
! INTEGER ExampleVariable !Description of variable PPTOANC1.3368
! Subroutine arguments PPTOANC1.3369
! Scalar arguments with intent(in): PPTOANC1.3370
integer ftin1 PPTOANC1.3371
logical ibm_to_cray PPTOANC1.3372
PPTOANC1.3373
! Array arguments with intent(in): PPTOANC1.3374
integer pp_int(45) PPTOANC1.3375
PPTOANC1.3376
real pp_real(19) PPTOANC1.3377
PPTOANC1.3378
! local scalars PPTOANC1.3379
integer ier PPTOANC1.3380
PPTOANC1.3381
! local arrays PPTOANC1.3382
integer pp_buffer(32) PPTOANC1.3383
PPTOANC1.3384
! functions called PPTOANC1.3385
integer ibm2cri PPTOANC1.3386
PPTOANC1.3387
! End of header PPTOANC1.3388
PPTOANC1.3389
if (ibm_to_cray) then PPTOANC1.3390
PPTOANC1.3391
C Read in the PP header PPTOANC1.3392
read(ftin1) pp_buffer PPTOANC1.3393
PPTOANC1.3394
C Convert Integer part of header (Words 1-45) PPTOANC1.3395
ier = ibm2cri (2,45,pp_buffer,0,pp_int,1,64,32) PPTOANC1.3396
PPTOANC1.3397
C Convert Real part of header (Words 46-64) PPTOANC1.3398
ier = ibm2cri (3,19,pp_buffer(23),32,pp_real,1,64,32) PPTOANC1.3399
PPTOANC1.3400
else PPTOANC1.3401
PPTOANC1.3402
C Read in the PP header PPTOANC1.3403
read(ftin1) pp_int,pp_real PPTOANC1.3404
PPTOANC1.3405
end if PPTOANC1.3406
PPTOANC1.3407
PPTOANC1.3408
return PPTOANC1.3409
end PPTOANC1.3410
PPTOANC1.3747
!+ Skip namelists in f90 compiled UM code removing need for PPTOANC1.3748
!+ assign -f 77 g:sf in script PPTOANC1.3749
! PPTOANC1.3750
! Subroutine Interface: PPTOANC1.3751
FUNCTION FIND_NAMELIST(iunit, namelist_name) 7PPTOANC1.3752
PPTOANC1.3753
implicit none PPTOANC1.3754
! PPTOANC1.3755
! Description: PPTOANC1.3756
! This routine searches the input stream given by 'iunit' PPTOANC1.3757
! to find the NAMELIST given by 'namelist_name'. The PPTOANC1.3758
! input file is then correctly positioned to let F90 PPTOANC1.3759
! library routines read the namelist. PPTOANC1.3760
! PPTOANC1.3761
! The namelist is assumed to be contained within the PPTOANC1.3762
! first 24 characters of the record PPTOANC1.3763
! PPTOANC1.3764
! Return values: PPTOANC1.3765
! PPTOANC1.3766
! -1 error - could not find the namelist - file is now PPTOANC1.3767
! at end-of-file. PPTOANC1.3768
! 0 namelist ready to be processed. PPTOANC1.3769
! PPTOANC1.3770
! Current Code Owner: I Edmond PPTOANC1.3771
! PPTOANC1.3772
! History: PPTOANC1.3773
! Version Date Comment PPTOANC1.3774
! ------- ---- ------- PPTOANC1.3775
! 4.4 15/6/96 Original code. Bob Carruthers PPTOANC1.3776
! PPTOANC1.3777
! Code Description: PPTOANC1.3778
! Language: FORTRAN 77 + common extensions. PPTOANC1.3779
! This code is written to UMDP3 v6 programming standards. PPTOANC1.3780
! PPTOANC1.3781
! PPTOANC1.3782
! Declarations: PPTOANC1.3783
! 1.0 Subroutine arguments PPTOANC1.3784
! 1.1 Scalar arguments with intent(in): PPTOANC1.3785
integer iunit PPTOANC1.3786
PPTOANC1.3787
! 1.2 Scalar arguments with intent(out): PPTOANC1.3788
character*(*) namelist_name PPTOANC1.3789
PPTOANC1.3790
integer find_namelist PPTOANC1.3791
PPTOANC1.3792
! 2.0 Local scalars: PPTOANC1.3793
integer i, j PPTOANC1.3794
PPTOANC1.3795
character*24 chvar PPTOANC1.3796
PPTOANC1.3797
!- End of header PPTOANC1.3798
PPTOANC1.3799
1000 continue PPTOANC1.3800
read(iunit, '(a)', end=9000, err=9000) chvar PPTOANC1.3801
PPTOANC1.3802
! Check for leading '&' for namelist PPTOANC1.3803
i=index(chvar, '&') PPTOANC1.3804
! Found '&' - check for the name we want PPTOANC1.3805
if(i.ne.0) then PPTOANC1.3806
j=index(chvar, namelist_name) PPTOANC1.3807
! Not the name we want - print skipped message PPTOANC1.3808
if(j.eq.0) then PPTOANC1.3809
if(index('endEndeNdenDENdEnDeNDEND', PPTOANC1.3810
2 chvar(i+1:i+3)).eq.0) then PPTOANC1.3811
write(0,*)'- Skipped record named: ', PPTOANC1.3812
2 chvar(i+1:),' On Unit:',iunit, PPTOANC1.3813
3 ' - f90 version' PPTOANC1.3814
endif PPTOANC1.3815
goto 1000 PPTOANC1.3816
endif PPTOANC1.3817
goto 1100 PPTOANC1.3818
endif PPTOANC1.3819
goto 1000 PPTOANC1.3820
PPTOANC1.3821
! Found the namelist we want - backspace to position correctly PPTOANC1.3822
1100 continue PPTOANC1.3823
backspace iunit PPTOANC1.3824
FIND_NAMELIST=0 PPTOANC1.3825
return PPTOANC1.3826
PPTOANC1.3827
! Cannot find the namelist we want PPTOANC1.3828
9000 continue PPTOANC1.3829
FIND_NAMELIST=1 PPTOANC1.3830
return PPTOANC1.3831
end PPTOANC1.3832
*ENDIF PPTOANC1.3833