PROGRAM FIELDOP ,15FIELDOP1.21
IMPLICIT NONE FIELDOP1.22
! FIELDOP1.23
! Routine: fieldop ------------------------------------------------- FIELDOP1.24
! FIELDOP1.25
! Description: FIELDOP1.26
! To read two model dumps or direct access fieldsfiles with unpacked FIELDOP1.27
! or packed (wgdos,grib,cray 32 bits) data and write out to a new file FIELDOP1.28
! the difference, sum or product of the data values. Alternatively FIELDOP1.29
! if a single dataset is read the data may be divided by an integer. FIELDOP1.30
! FIELDOP1.31
! Method: FIELDOP1.32
! FIELDOP1.33
! Current Code Owner: I Edmond FIELDOP1.34
! FIELDOP1.35
! History: FIELDOP1.36
! Version Date Comment FIELDOP1.37
! ------- ---- ------- FIELDOP1.38
! 4.3 20/2/97 Code added to enable fieldop (1) to perform UIE0F403.1
! arithmetic operations on individual levels of specified fields UIE0F403.2
! (indicated by lblev and lbuser3), (2) specify which data/ UIE0F403.3
! validity times (file1 or file2) are written out to output file. UIE0F403.4
! (See fieldop script for details). UIE0F403.5
! As the dimensions of a wgdos packed field depends on the size of UIE0F403.6
! the data values; having operated on fieldsfiles it is UIE0F403.7
! necessary to write data out to new addresses. Corrections were UIE0F403.8
! made to code to do this. Ian Edmond. UIE0F403.9
! 4.4 17/7/97 Fix to subroutine READFF to read wfio dumpfiles. UIE0F404.24
! Initialise icode =0 now that it is not done in hdppxrf IE UIE0F404.25
CLL 4.4 Oct. 1997 Changed error handling from routine HDPPXRF GDW1F404.165
CLL so only fatal (+ve) errors are handled. GDW1F404.166
CLL Shaun de Witt GDW1F404.167
! 4.5 14/07/98 Initialised UM_SECTOR_SIZE from BLKDATA GAV0F405.1
! (A Van der Wal) GAV0F405.2
! 4.5 23/11/98 Use UM_SECTOR_SIZE instead of hardwired 512 in UDG1F405.1558
! pp_file. Automatically skip mathematical UDG1F405.1559
! operations on land-sea mask, to prevent failure UDG1F405.1560
! with fieldsfiles. UDG1F405.1561
! Author D.M. Goddard UDG1F405.1562
! FIELDOP1.40
! Code Description: FIELDOP1.41
! Language: FORTRAN 77 + common extensions. FIELDOP1.42
! This code is written to UMDP3 v6 programming standards. FIELDOP1.43
! FIELDOP1.44
! System component covered: <appropriate code> FIELDOP1.45
! System Task: <appropriate code> FIELDOP1.46
! FIELDOP1.47
! Declarations: FIELDOP1.48
! These are of the form:- FIELDOP1.49
! INTEGER ExampleVariable !Description of variable FIELDOP1.50
! FIELDOP1.51
! Routine arguments FIELDOP1.52
! Scalar arguments FIELDOP1.53
INTEGER FIELDOP1.54
& i, ! Counter. FIELDOP1.55
& len2_lookup, ! Size of the lookup on the file UIE0F403.10
& len2_lookup2, ! Size of the lookup on the file UIE0F403.11
& max_len2_lookup,! Size of the lookup on the file UIE0F403.12
& LEN_INTHD, UIE0F403.13
& LEN_REALHD, UIE0F403.14
& LEN1_LEVDPC, UIE0F403.15
& LEN2_LEVDPC, UIE0F403.16
& pp_unit_out, ! Unit no of output file; value varies FIELDOP1.58
& ! - depends on 1 or 2 i/p files. FIELDOP1.59
& icode, ! Return code FIELDOP1.60
& data_add1, ! The word address of the data. FIELDOP1.61
& data_add2, ! The word address of the data. FIELDOP1.62
& iwa, ! Word address in call setpos FIELDOP1.63
& iwa2, ! Word address in call setpos FIELDOP1.64
& len_io, ! Length of IO done FIELDOP1.65
& l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,l11,l12, UIE0F403.17
& l13,l14,l15,l16,l17,l18,l19,l20, UIE0F403.18
& stash1,stash2,stash3,stash4,stash5, ! Stash codes of fields FIELDOP1.66
& stash6,stash7,stash8,stash9,stash10, ! which are not operated FIELDOP1.67
& stash11,stash12,stash13,stash14,stash15, ! upon. FIELDOP1.68
& stash16,stash17,stash18,stash19,stash20, ! FIELDOP1.69
& divisor, ! Integer divisor for data in file 1 if required FIELDOP1.70
& err, ! Error code. FIELDOP1.71
& OpenStatus FIELDOP1.72
&,ustash FIELDOP1.73
FIELDOP1.74
REAL FIELDOP1.75
& a_io ! status returned by buffin FIELDOP1.76
FIELDOP1.77
CHARACTER FIELDOP1.78
& cmessage*80 ! Error message from lower routines FIELDOP1.79
& ,op*8 ! Operation type +,-,* FIELDOP1.80
FIELDOP1.81
CHARACTER NOMLIST*80 UIE0F403.19
UIE0F403.20
LOGICAL UIE0F403.21
& nfields UIE0F403.22
&,tfields UIE0F403.23
&,llev UIE0F403.24
&,Tcopy UIE0F403.25
FIELDOP1.82
! Parameters: FIELDOP1.83
INTEGER len_fixhd ! Length of fixed length header FIELDOP1.84
PARAMETER(len_fixhd=256) FIELDOP1.85
FIELDOP1.86
INTEGER len1_lookup ! First dim. of the lookup of 1st dump FIELDOP1.87
PARAMETER(len1_lookup=64) FIELDOP1.88
FIELDOP1.89
INTEGER len1_lookup2 ! First dim. of the lookup of 2nd dump FIELDOP1.90
PARAMETER(len1_lookup2=64) FIELDOP1.91
FIELDOP1.92
INTEGER pp_unit1 ! Unit number of input dump/fieldsfile. FIELDOP1.93
PARAMETER(pp_unit1=20) FIELDOP1.94
FIELDOP1.95
INTEGER pp_unit2 ! Unit number of 2nd i/p dump/fieldsfile. FIELDOP1.96
PARAMETER(pp_unit2=21) FIELDOP1.97
FIELDOP1.98
! Array arguments: FIELDOP1.99
INTEGER FIELDOP1.100
& pp_fixhd(len_fixhd), ! Fixed length header of 1st file. FIELDOP1.101
& pp_fixhd2(len_fixhd) ! Fixed length header of 2nd file. FIELDOP1.102
FIELDOP1.103
! Function & Subroutine calls: FIELDOP1.104
External readff,setpos,ioerror,fieldop_main FIELDOP1.105
FIELDOP1.106
*CALL CNTL_IO 
GAV0F405.3
UIE0F404.52
DATA l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,l11,l12, UIE0F403.26
& l13,l14,l15,l16,l17,l18,l19,l20 / UIE0F403.27
& 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, UIE0F403.28
& 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 / UIE0F403.29
UIE0F403.30
DATA stash1,stash2,stash3,stash4,stash5, UIE0F403.31
& stash6,stash7,stash8,stash9,stash10, UIE0F403.32
& stash11,stash12,stash13,stash14,stash15, UIE0F403.33
& stash16,stash17,stash18,stash19,stash20 / UIE0F403.34
& 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, UIE0F403.35
& 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 / UIE0F403.36
UIE0F403.37
!- End of header FIELDOP1.107
FIELDOP1.108
!------------------------------------------------------------------ FIELDOP1.109
! Read in the Fixed Length Headers of files 1 and 2. FIELDOP1.110
!------------------------------------------------------------------ FIELDOP1.111
FIELDOP1.112
namelist/CONTROL/op,divisor,nfields,tfields,llev,Tcopy UIE0F403.38
namelist/STASHES/stash1,stash2,stash3,stash4,stash5, FIELDOP1.114
& stash6,stash7,stash8,stash9,stash10, FIELDOP1.115
& stash11,stash12,stash13,stash14,stash15, FIELDOP1.116
& stash16,stash17,stash18,stash19,stash20 FIELDOP1.117
namelist/LEVELS/l1,l2,l3,l4,l5, UIE0F403.39
& l6,l7,l8,l9,l10, UIE0F403.40
& l11,l12,l13,l14,l15, UIE0F403.41
& l16,l17,l18,l19,l20 UIE0F403.42
namelist/USTSFILE/ustash FIELDOP1.118
FIELDOP1.119
! Initialise error code. UIE0F404.26
icode = 0 UIE0F404.27
UIE0F404.28
Call GET_FILE(5,NOMLIST,80,ICODE) UIE0F403.43
OPEN(UNIT=5,FILE=NOMLIST,DELIM='APOSTROPHE') PXNAMLST.1
read(5,CONTROL) FIELDOP1.120
read(5,STASHES) FIELDOP1.121
read(5,LEVELS) UIE0F403.45
read(5,USTSFILE) FIELDOP1.122
FIELDOP1.123
len2_lookup = 0 UIE0F403.46
len2_lookup2 = 0 UIE0F403.47
! Open 1st dump or fieldsfile. FIELDOP1.124
call file_open(pp_unit1,'FILE1',5,0,0,err) FIELDOP1.125
FIELDOP1.126
If (op .ne. 'idiv ') then FIELDOP1.127
FIELDOP1.128
! Open 2nd dump or fieldsfile and output file. FIELDOP1.129
call file_open(pp_unit2,'FILE2',5,0,0,err) FIELDOP1.130
FIELDOP1.131
pp_unit_out =22 FIELDOP1.132
call file_open(pp_unit_out,'FILE3',5,1,0,err) FIELDOP1.133
Else FIELDOP1.134
FIELDOP1.135
! Only one dump or fieldsfile needed, open output file. FIELDOP1.136
pp_unit_out=21 FIELDOP1.137
call file_open(pp_unit_out,'FILE2',5,1,0,err) FIELDOP1.138
FIELDOP1.139
End if FIELDOP1.140
FIELDOP1.141
! Read fixed header of first file. FIELDOP1.142
call buffin(pp_unit1,pp_fixhd,len_fixhd,len_io,a_io) FIELDOP1.143
FIELDOP1.144
! Error check. FIELDOP1.145
If (a_io .ne. -1.0 .or. len_io .ne. len_fixhd) then FIELDOP1.146
FIELDOP1.147
call ioerror('Buffer in fixed length header',a_io,len_io, FIELDOP1.148
& len_fixhd) FIELDOP1.149
cmessage ='FIELDOP : I/O error reading Fixed Length Header' FIELDOP1.150
icode =2 FIELDOP1.151
write(*,*)' I/O error reading Fixed Length Header' FIELDOP1.152
call abort(" Failed in FIELDOP ") FIELDOP1.153
FIELDOP1.154
End if FIELDOP1.155
FIELDOP1.156
data_add1 = pp_fixhd(160) -1 ! Start address for the data. FIELDOP1.157
iwa = pp_fixhd(150) -1 ! Start address of lookup table. FIELDOP1.158
len2_lookup = pp_fixhd(152) ! 2nd dim of lookup of file1. UIE0F403.48
FIELDOP1.160
write(*,*)' dump type=',pp_fixhd(5), FIELDOP1.161
& ' 3=fieldsfile,1=dump,2=time mean dump,4=ancil,5=bound' FIELDOP1.162
FIELDOP1.163
If (op .ne. 'idiv ') then FIELDOP1.164
FIELDOP1.165
! Read fixed header of second file. FIELDOP1.166
call buffin(pp_unit2,pp_fixhd2,len_fixhd,len_io,a_io) FIELDOP1.167
FIELDOP1.168
! Error check. FIELDOP1.169
If(a_io .ne. -1.0 .or. len_io .ne. len_fixhd) then FIELDOP1.170
FIELDOP1.171
call ioerror('Buffer in fixed length header2',a_io,len_io, FIELDOP1.172
& len_fixhd) FIELDOP1.173
cmessage='FIELDOP : I/O error reading Fixed Length Header' FIELDOP1.174
icode=2 FIELDOP1.175
write(*,*)' I/O error reading Fixed Length Header' FIELDOP1.176
call abort(" Failed in FIELDOP ") FIELDOP1.177
FIELDOP1.178
End if FIELDOP1.179
FIELDOP1.180
data_add2 = pp_fixhd2(160)-1 ! Start address for the data. FIELDOP1.181
iwa2 = pp_fixhd2(150)-1 ! Start address of lookup. FIELDOP1.182
len2_lookup2 = pp_fixhd2(152) ! 2nd dim of lookup of file2. UIE0F403.49
FIELDOP1.184
! Compare fixed length headers FIELDOP1.185
write(6,*)' ' FIELDOP1.186
write(6,*)'Fixed Length Header:' FIELDOP1.187
FIELDOP1.188
Do i =1,len_fixhd FIELDOP1.189
FIELDOP1.190
If (pp_fixhd(i) .ne. pp_fixhd2(i)) then FIELDOP1.191
FIELDOP1.192
write(6,*)'Item=',I,pp_fixhd(I),pp_fixhd2(I) FIELDOP1.193
! Abort if files 1 and 2 have different indicators for FIELDOP1.194
! dataset type. FIELDOP1.195
If (i.eq.5) then FIELDOP1.196
call abort(" ERROR: Different dataset types") FIELDOP1.197
End if FIELDOP1.198
FIELDOP1.199
End if FIELDOP1.200
FIELDOP1.201
End do ! i FIELDOP1.202
FIELDOP1.203
End if FIELDOP1.204
FIELDOP1.205
max_len2_lookup=MAX(len2_lookup,len2_lookup2) UIE0F403.50
UIE0F403.51
call fieldop_main(len2_lookup, !IN 2nd dim of lookup of file1. UIE0F403.52
& max_len2_lookup,!IN 1st dim of lookup (file1). UIE0F403.53
& len1_lookup, !IN 1st dim of lookup (file1). FIELDOP1.207
& data_add1, !IN Start address for data FIELDOP1.208
& ! in 1st file. FIELDOP1.209
& pp_fixhd, !IN Fixed header of 1st file. FIELDOP1.210
& pp_fixhd2, !IN Fixed header of 2nd file. FIELDOP1.211
& len_fixhd, !IN Fixed header length FIELDOP1.212
& pp_unit2, !IN Unit no. of 2nd i/p dataset. FIELDOP1.213
& op, !IN Operation type +,-,* (char) FIELDOP1.214
& iwa, !IN Start address for the lookup FIELDOP1.215
& ! table of 1st file. FIELDOP1.216
& pp_unit1, !IN Unit no. of 1st i/p dataset. FIELDOP1.217
& pp_unit_out, !IN Unit number of o/p file. FIELDOP1.218
& divisor, !IN Integer divisor for data FIELDOP1.219
& ! in file 1 if required. FIELDOP1.220
& len2_lookup2,!IN 2nd dim of lookup of file2. UIE0F403.54
& len1_lookup2, !IN 1st dim of lookup (file2). FIELDOP1.222
& data_add2, !IN Start address for data FIELDOP1.223
& ! in 2nd file. FIELDOP1.224
& iwa2, !IN Start address for the lookup FIELDOP1.225
& ! table of 2nd file. FIELDOP1.226
& nfields, UIE0F403.55
& tfields, UIE0F403.56
& llev, UIE0F403.57
& Tcopy, UIE0F403.58
& l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,l11,l12, UIE0F403.59
& l13,l14,l15,l16,l17,l18,l19,l20, UIE0F403.60
& stash1,stash2,stash3,stash4,stash5, FIELDOP1.227
& stash6,stash7,stash8,stash9,stash10, FIELDOP1.228
& stash11,stash12,stash13,stash14,stash15, FIELDOP1.229
& stash16,stash17,stash18,stash19,stash20, FIELDOP1.230
& ustash, !IN =1 if user STASHmaster file FIELDOP1.231
& icode,cmessage) ! =0 if no user STASHmaster FIELDOP1.232
FIELDOP1.233
If (icode.ne.0) then FIELDOP1.234
FIELDOP1.235
call ereport(icode,cmessage) FIELDOP1.236
call abort(" Failed in FIELDOP ") FIELDOP1.237
End if FIELDOP1.238
FIELDOP1.239
STOP FIELDOP1.240
END FIELDOP1.241
! FIELDOP1.242
! Subroutine interface: FIELDOP1.243
SUBROUTINE fieldop_main(pp_len2_lookup, 1,26FIELDOP1.244
& max_len2_lookup, UIE0F403.61
& len1_lookup, FIELDOP1.245
& data_add1, FIELDOP1.246
& pp_fixhd, FIELDOP1.247
& pp_fixhd2, FIELDOP1.248
& len_fixhd, FIELDOP1.249
& pp_unit2, FIELDOP1.250
& op, FIELDOP1.251
& iwa, FIELDOP1.252
& pp_unit1, FIELDOP1.253
& pp_unit_out, FIELDOP1.254
& divisor, FIELDOP1.255
& pp_len2_lookup2, FIELDOP1.256
& len1_lookup2, FIELDOP1.257
& data_add2, FIELDOP1.258
& iwa2, FIELDOP1.259
& nfields, UIE0F403.62
& tfields, UIE0F403.63
& llev, UIE0F403.64
& Tcopy, UIE0F403.65
& l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,l11,l12, UIE0F403.66
& l13,l14,l15,l16,l17,l18,l19,l20, UIE0F403.67
& stash1,stash2,stash3,stash4,stash5, FIELDOP1.260
& stash6,stash7,stash8,stash9,stash10, FIELDOP1.261
& stash11,stash12,stash13,stash14,stash15, FIELDOP1.262
& stash16,stash17,stash18,stash19,stash20, FIELDOP1.263
& ustash, FIELDOP1.264
& icode,cmessage) FIELDOP1.265
IMPLICIT NONE FIELDOP1.266
! FIELDOP1.267
! Description: Read in the lookup tables for files 1 and 2, find FIELDOP1.268
! lengths of current record, checking that the number of FIELDOP1.269
! values in field agree in both files. Obtain also, the FIELDOP1.270
! PPXREF codes for each field. FIELDOP1.271
! Method: FIELDOP1.272
! FIELDOP1.273
! Current Code Owner: I Edmond FIELDOP1.274
! FIELDOP1.275
! History: FIELDOP1.276
! Version Date Comment FIELDOP1.277
! ------- ---- ------- FIELDOP1.278
! <version> <date> Original code. <Your name> FIELDOP1.279
! FIELDOP1.280
! Code Description: FIELDOP1.281
! Language: FORTRAN 77 + common extensions. FIELDOP1.282
! This code is written to UMDP3 v6 programming standards. FIELDOP1.283
! FIELDOP1.284
! System component covered: <appropriate code> FIELDOP1.285
! System Task: <appropriate code> FIELDOP1.286
! FIELDOP1.287
! Declarations: FIELDOP1.288
! These are of the form:- FIELDOP1.289
! INTEGER ExampleVariable !Description of variable FIELDOP1.290
! FIELDOP1.291
! 1.0 Global variables (*CALLed COMDECKs etc...): FIELDOP1.292
*CALL CSUBMODL FIELDOP1.293
*CALL CPPXREF FIELDOP1.294
*CALL PPXLOOK FIELDOP1.295
*CALL CSTASH FIELDOP1.296
*CALL CLOOKADD FIELDOP1.297
*CALL C_MDI FIELDOP1.298
FIELDOP1.299
! Subroutine arguments FIELDOP1.300
! Scalar arguments with intent(in): FIELDOP1.301
INTEGER FIELDOP1.302
& len1_lookup, ! 1st dimension of lookup FIELDOP1.303
& len1_lookup2, ! 1st dimension of lookup FIELDOP1.304
& pp_len2_lookup, ! 2nd dimension of lookup FIELDOP1.305
& pp_len2_lookup2, ! 2nd dimension of lookup FIELDOP1.306
& max_len2_lookup, ! 2nd dimension of lookup UIE0F403.68
& len_fixhd, FIELDOP1.307
& pp_unit1, ! unit no of required fieldsfile FIELDOP1.308
& pp_unit2, ! unit no of required fieldsfile FIELDOP1.309
& pp_unit_out, ! unit no of output file FIELDOP1.310
& data_add1, ! Start address of data in 1st file; Word FIELDOP1.311
& ! address of the data. FIELDOP1.312
& data_add2, ! Start address of data in 2nd file; Word FIELDOP1.313
& ! address of the data. FIELDOP1.314
& iwa, ! Start address of lookup in 1st file; Word FIELDOP1.315
& ! address in call setpos FIELDOP1.316
& iwa2, ! Start address of lookup in 2nd file; Word FIELDOP1.317
& ! address in call setpos FIELDOP1.318
& stash1,stash2,stash3,stash4,stash5, ! Stash codes of fields FIELDOP1.319
& stash6,stash7,stash8,stash9,stash10, ! not operated upon. FIELDOP1.320
& stash11,stash12,stash13,stash14,stash15, ! FIELDOP1.321
& stash16,stash17,stash18,stash19,stash20, ! FIELDOP1.322
& l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,l11,l12, UIE0F403.69
& l13,l14,l15,l16,l17,l18,l19,l20, UIE0F403.70
& divisor ! Integer divisor (file1 only) FIELDOP1.323
FIELDOP1.324
CHARACTER FIELDOP1.325
& op*8 FIELDOP1.326
FIELDOP1.327
! Array arguments with intent(in): FIELDOP1.328
INTEGER FIELDOP1.329
& pp_fixhd(len_fixhd), ! Dump/fieldsfile fixed header FIELDOP1.330
& pp_fixhd2(len_fixhd), ! Dump/fieldsfile fixed header FIELDOP1.331
& lookup(len1_lookup,pp_len2_lookup), ! Integer lookup of file1. FIELDOP1.332
& lookup2(len1_lookup2,pp_len2_lookup2) ! Integer lookup of file2. FIELDOP1.333
FIELDOP1.334
! Array arguments with intent(out): FIELDOP1.335
FIELDOP1.336
! ErrorStatus FIELDOP1.337
INTEGER FIELDOP1.338
& icode FIELDOP1.339
FIELDOP1.340
CHARACTER FIELDOP1.341
& cmessage*80 FIELDOP1.342
FIELDOP1.343
! Local parameters: FIELDOP1.344
INTEGER nft1,nft2 FIELDOP1.345
PARAMETER(nft1=22, nft2=2) FIELDOP1.346
FIELDOP1.347
! Local scalars: FIELDOP1.348
INTEGER FIELDOP1.349
& i,j,k, ! local counters FIELDOP1.350
& nent, ! No of entries in the printfile FIELDOP1.351
& len1, ! Number of fields in File1 FIELDOP1.352
& len2, ! Number of fields in File2 FIELDOP1.353
& err, ! error code. FIELDOP1.354
& num_values, ! No. of points in data field UIE0F403.71
& idim, ! num_values rounded to an even no FIELDOP1.357
& max_len, ! used to dimension the data array FIELDOP1.358
& len_i, ! No of data points in a fieldsfile field FIELDOP1.359
& ! used to find max_len. FIELDOP1.360
& entry_no, ! lookup entry no of the field. FIELDOP1.361
& entry_no2, ! lookup entry no of the field. FIELDOP1.362
& dummy, FIELDOP1.363
& len_io, ! actual no of words transferred by IO. FIELDOP1.364
& len_io_expected, ! expected no of words transferred by IO FIELDOP1.365
& exppxi, FIELDOP1.366
& rownumber FIELDOP1.367
& ,ustash FIELDOP1.368
FIELDOP1.369
REAL FIELDOP1.370
& a_io ! status returned by buffin / buffout UIE0F403.72
FIELDOP1.372
CHARACTER FIELDOP1.373
& exppxc*(36) FIELDOP1.374
FIELDOP1.375
LOGICAL FIELDOP1.376
& model_flag, ! flag - set to true if model dump FIELDOP1.377
& lmore, FIELDOP1.379
& l_copy, UIE0F403.73
& nfields, UIE0F403.74
& tfields, UIE0F403.75
& llev, UIE0F403.76
& ignore, UIE0F403.77
& Tcopy UIE0F403.78
FIELDOP1.381
! Local dynamic arrays: FIELDOP1.382
INTEGER FIELDOP1.383
& pos1(max_len2_lookup), ! Array of field positions in lookup1. UIE0F403.79
& pos2(max_len2_lookup) ! Equivalent field positions in lookup2. UIE0F403.80
FIELDOP1.386
! Function & Subroutine calls: FIELDOP1.387
External readff,read_write,writeff,ioerror,readstm FIELDOP1.388
FIELDOP1.389
!- End of header FIELDOP1.390
FIELDOP1.391
! Alter data and validity times in lookup tables so that lookup(1) UIE0F403.81
! -> lookup(14) taken from second file rather than first if UIE0F403.82
! logical Tcopy is TRUE. UIE0F403.83
If (Tcopy) then UIE0F403.84
UIE0F403.85
! Copy fixed header from pp_fixhd2 into pp_fixhd. UIE0F403.86
Do j=21,41 UIE0F403.87
pp_fixhd(j) = pp_fixhd2(j) UIE0F403.88
End do UIE0F403.89
call setpos(pp_unit_out,0,icode) UIE0F403.90
call buffout(pp_unit_out,pp_fixhd(1),len_fixhd,len_io,a_io) UIE0F403.91
UIE0F403.92
! Check for I/O errors UIE0F403.93
If (a_io .ne. -1.0 .or. len_io .ne. len_fixhd) then UIE0F403.94
UIE0F403.95
call ioerror('buffer out of fixed header',a_io,len_io, UIE0F403.96
* len_fixhd) UIE0F403.97
cmessage='FIELDOP: I/O error' UIE0F403.98
icode=25 UIE0F403.99
return UIE0F403.100
End if UIE0F403.101
End if UIE0F403.102
UIE0F403.103
! Read in the lookup table of file1 if first time through FIELDOP1.392
call setpos(pp_unit1,iwa,icode) FIELDOP1.393
FIELDOP1.394
len_io_expected=pp_len2_lookup*len1_lookup FIELDOP1.395
call buffin(pp_unit1,lookup,len_io_expected,len_io,a_io) FIELDOP1.396
FIELDOP1.397
If (a_io.ne.-1.0 .or. len_io .ne. len_io_expected) then FIELDOP1.398
FIELDOP1.399
call ioerror('Buffer in lookup table ',a_io,len_io, FIELDOP1.400
& len_io_expected ) FIELDOP1.401
cmessage='fieldop_main: I/O error reading lookup table ' FIELDOP1.402
icode=3 FIELDOP1.403
write(*,*)' I/O error reading lookup table' FIELDOP1.404
return FIELDOP1.405
FIELDOP1.406
End if FIELDOP1.407
FIELDOP1.408
! Find which internal models are present and read in information from FIELDOP1.409
! STASHmaster and user-STASHmaster files required by writflds. FIELDOP1.410
FIELDOP1.411
! Find which internal models are present. FIELDOP1.412
internal_model_index(1) = 0 FIELDOP1.413
internal_model_index(2) = 0 FIELDOP1.414
internal_model_index(3) = 0 FIELDOP1.415
internal_model_index(4) = 0 FIELDOP1.416
n_internal_model = 1 FIELDOP1.417
FIELDOP1.418
if (pp_fixhd(12).lt.400)then FIELDOP1.419
FIELDOP1.420
do i =1, pp_len2_lookup FIELDOP1.421
FIELDOP1.422
! Section 0: Prognostic fields. FIELDOP1.423
if(lookup(42,i).le.100.or. FIELDOP1.424
& (lookup(42,i).ge.200.and.lookup(42,i).le.205))then FIELDOP1.425
lookup(45,i)=1 FIELDOP1.426
FIELDOP1.427
else if((lookup(42,i).GT.100.and.lookup(42,i).le.176).or. FIELDOP1.428
& (lookup(42,i).ge.180.and.lookup(42,i).lt.200))then FIELDOP1.429
lookup(45,i)=2 FIELDOP1.430
FIELDOP1.431
else if((lookup(42,i).ge.177.and.lookup(42,i).le.179).or. FIELDOP1.432
& (lookup(42,i).ge.210.and.lookup(42,i).le.212))then FIELDOP1.433
lookup(45,i)=3 FIELDOP1.434
FIELDOP1.435
! Sections 1 - 99: Diagnostic fields FIELDOP1.436
else if(lookup(42,i).ge.1000.and.lookup(42,i).le.29999)then FIELDOP1.437
if((lookup(42,i).ge.21177.and.lookup(42,i).le.21179).or. FIELDOP1.438
& (lookup(42,i).ge.21225.and.lookup(42,i).le.21227).or. FIELDOP1.439
& (lookup(42,i).ge.22177.and.lookup(42,i).le.22179).or. FIELDOP1.440
& (lookup(42,i).ge.22225.and.lookup(42,i).le.22227).or. FIELDOP1.441
& (lookup(42,i).ge.23177.and.lookup(42,i).le.23179).or. FIELDOP1.442
& (lookup(42,i).ge.23225.and.lookup(42,i).le.23227).or. FIELDOP1.443
& (lookup(42,i).ge.24177.and.lookup(42,i).le.24179).or. FIELDOP1.444
& (lookup(42,i).ge.24225.and.lookup(42,i).le.24227))then FIELDOP1.445
lookup(45,i)=3 !Slab diagnostic FIELDOP1.446
FIELDOP1.447
else FIELDOP1.448
lookup(45,i)=1 !Atmosphere diagnostic FIELDOP1.449
FIELDOP1.450
end if FIELDOP1.451
FIELDOP1.452
else if(lookup(42,i).ge.30000.and.lookup(42,i).le.99999)then FIELDOP1.453
if(lookup(42,i).ge.40000.and.lookup(42,i).le.40999)then FIELDOP1.454
lookup(45,i)=3 !Slab diagnostic FIELDOP1.455
FIELDOP1.456
else FIELDOP1.457
lookup(45,i)=2 !Ocean diagnostic FIELDOP1.458
FIELDOP1.459
end if FIELDOP1.460
FIELDOP1.461
else FIELDOP1.462
write(6,*) 'WARNING: User defined field found - ', FIELDOP1.463
& 'STASH code : ', lookup(42,i) FIELDOP1.464
write(6,*) ' Internal model number can not be defined.' FIELDOP1.465
write(6,*) ' Setting internal model number to atmosphere.' FIELDOP1.466
lookup(45,i)=1 FIELDOP1.467
FIELDOP1.468
end if FIELDOP1.469
FIELDOP1.470
end do FIELDOP1.471
FIELDOP1.472
end if FIELDOP1.473
FIELDOP1.474
do i =1, pp_len2_lookup FIELDOP1.475
l_copy=.true. FIELDOP1.476
do j =1,n_internal_model FIELDOP1.477
if (lookup(45,i).eq.internal_model_index(j)) then FIELDOP1.478
l_copy =.false. FIELDOP1.479
end if FIELDOP1.480
end do FIELDOP1.481
if (l_copy) then FIELDOP1.482
internal_model_index(n_internal_model) = lookup(45,i) FIELDOP1.483
n_internal_model = n_internal_model +1 FIELDOP1.484
end if FIELDOP1.485
end do FIELDOP1.486
n_internal_model = n_internal_model -1 FIELDOP1.487
FIELDOP1.488
! Read in STASHmaster file FIELDOP1.489
ppxRecs=1 FIELDOP1.490
RowNumber=0 FIELDOP1.491
do i=1,n_internal_model FIELDOP1.492
FIELDOP1.493
if(internal_model_index(i).eq.1)then FIELDOP1.494
call hdppxrf(nft1,'STASHmaster_A',ppxRecs,icode,cmessage) FIELDOP1.495
else if(internal_model_index(i).eq.2)then FIELDOP1.496
call hdppxrf(nft1,'STASHmaster_O',ppxRecs,icode,cmessage) FIELDOP1.497
else if(internal_model_index(i).eq.3)then FIELDOP1.498
call hdppxrf(nft1,'STASHmaster_S',ppxRecs,icode,cmessage) FIELDOP1.499
end if FIELDOP1.500
FIELDOP1.501
IF(ICODE.GT.0)THEN GDW1F404.168
write(6,*) cmessage FIELDOP1.503
call abort FIELDOP1.504
end if FIELDOP1.505
FIELDOP1.506
if(internal_model_index(i).eq.1)then FIELDOP1.507
call getppx(nft1,nft2,'STASHmaster_A',RowNumber, FIELDOP1.508
*CALL ARGPPX FIELDOP1.509
& icode,cmessage) FIELDOP1.510
else if(internal_model_index(I).eq.2)then FIELDOP1.511
call getppx(nft1,nft2,'STASHmaster_O',RowNumber, FIELDOP1.512
*CALL ARGPPX FIELDOP1.513
& icode,cmessage) FIELDOP1.514
else if(internal_model_index(I).eq.3)then FIELDOP1.515
call getppx(nft1,nft2,'STASHmaster_S',RowNumber, FIELDOP1.516
*CALL ARGPPX FIELDOP1.517
& icode,cmessage) FIELDOP1.518
end if FIELDOP1.519
FIELDOP1.520
if(icode.ne.0)then FIELDOP1.521
write(6,*) cmessage FIELDOP1.522
call abort FIELDOP1.523
end if FIELDOP1.524
FIELDOP1.525
end do FIELDOP1.526
FIELDOP1.527
FIELDOP1.528
!User STASHmaster FIELDOP1.529
if (ustash.ne.0) then FIELDOP1.530
FIELDOP1.531
call hdppxrf(0,' ',ppxRecs,icode,cmessage) FIELDOP1.532
FIELDOP1.533
if(icode.ne.0)then FIELDOP1.534
write(6,*) cmessage FIELDOP1.535
call abort FIELDOP1.536
end if FIELDOP1.537
FIELDOP1.538
call getppx(0,nft2,' ',RowNumber, FIELDOP1.539
*CALL ARGPPX FIELDOP1.540
& icode,cmessage) FIELDOP1.541
FIELDOP1.542
if(icode.ne.0)then FIELDOP1.543
write(6,*) cmessage FIELDOP1.544
call abort FIELDOP1.545
end if FIELDOP1.546
FIELDOP1.547
end if FIELDOP1.548
FIELDOP1.549
FIELDOP1.550
! Read in the lookup table of file2 if first time through. FIELDOP1.551
If (op .ne. 'idiv ') then FIELDOP1.552
FIELDOP1.553
call setpos(pp_unit2,iwa2,icode) FIELDOP1.554
FIELDOP1.555
len_io_expected=pp_len2_lookup2*len1_lookup2 FIELDOP1.556
call buffin(pp_unit2,lookup2,len_io_expected,len_io,a_io) FIELDOP1.557
FIELDOP1.558
If(a_io .ne. -1.0 .or. len_io .ne. len_io_expected) then FIELDOP1.559
FIELDOP1.560
call ioerror('Buffer in lookup table2 ',a_io,len_io, FIELDOP1.561
& len_io_expected ) FIELDOP1.562
cmessage='fieldop_main: I/O error reading lookup table ' FIELDOP1.563
icode=3 FIELDOP1.564
write(*,*)' I/O error reading lookup table' FIELDOP1.565
return FIELDOP1.566
FIELDOP1.567
End if FIELDOP1.568
End if FIELDOP1.569
FIELDOP1.570
! Calculate the number of fields in File1 FIELDOP1.573
len1=0 FIELDOP1.574
Do i =1,pp_len2_lookup FIELDOP1.575
FIELDOP1.576
pos1(i)=-1 UIE0F403.104
If (lookup(lbrow,i) .ne. -99) then FIELDOP1.578
FIELDOP1.579
len1 =len1 +1 FIELDOP1.580
Else FIELDOP1.581
FIELDOP1.582
goto 2 FIELDOP1.583
End if FIELDOP1.584
FIELDOP1.585
End do FIELDOP1.586
2 continue FIELDOP1.587
FIELDOP1.588
If (OP .ne. 'idiv ') then FIELDOP1.589
FIELDOP1.590
! Calculate the number of fields in File2 FIELDOP1.591
len2 =0 FIELDOP1.592
Do i=1,pp_len2_lookup2 FIELDOP1.593
FIELDOP1.594
pos2(i)=-1 UIE0F403.105
If (lookup2(lbrow,i) .ne. -99) then FIELDOP1.596
FIELDOP1.597
len2 =len2 +1 FIELDOP1.598
Else FIELDOP1.599
FIELDOP1.600
goto 3 FIELDOP1.601
End if FIELDOP1.602
FIELDOP1.603
End do ! i FIELDOP1.604
3 continue FIELDOP1.605
FIELDOP1.606
! Find positions of corresponding fields in files 1 and 2; FIELDOP1.607
! Store field positions in pos1 and equivalent file2 field FIELDOP1.608
! positions in pos2. FIELDOP1.609
Do k =1,len1 FIELDOP1.611
FIELDOP1.612
Do i =1,len2 FIELDOP1.613
FIELDOP1.614
FIELDOP1.623
If ((lookup(42,k) .eq. lookup2(42,i)) .and. FIELDOP1.624
& (lookup(18,k) .eq. lookup2(18,i)) .and. UIE0F403.106
& (lookup(19,k) .eq. lookup2(19,i)) .and. UIE0F403.107
& (lookup(32,k) .eq. lookup2(32,i)) .and. UIE0F403.108
& (lookup(33,k) .eq. lookup2(33,i))) then UIE0F403.109
FIELDOP1.628
Do j=1,k UIE0F403.110
If (i .eq. pos2(j)) goto 4 UIE0F403.111
End do UIE0F403.112
pos1(k) =k UIE0F403.113
pos2(k) =i UIE0F403.114
goto 5 FIELDOP1.632
FIELDOP1.634
End if FIELDOP1.635
FIELDOP1.636
4 continue FIELDOP1.637
End do FIELDOP1.638
5 continue FIELDOP1.639
End do FIELDOP1.640
FIELDOP1.641
Else FIELDOP1.642
Do k=1,len1 FIELDOP1.644
pos1(k) =k UIE0F403.115
End do FIELDOP1.648
FIELDOP1.649
End if FIELDOP1.650
FIELDOP1.651
! Note lbrow=18,lbnpt=19 FIELDOP1.652
! For a DUMP lblrec will hold original no of data points. FIELDOP1.653
! LBNREC will be set to zero. FIELDOP1.654
! FIELDOP1.655
! For a PP_file lblrec will hold the no of CRAY words needed to hold FIELDOP1.656
! the data. The original field size will be rows*columns. FIELDOP1.657
! If the data is not packed then lblrec=lbrow*lbnpt+lbext, where FIELDOP1.658
! lbext will be greater than 0 for timeseries (which are never packed). FIELDOP1.659
! !! WARNING lbext - may be -32768 MISSING VALUE !! FIELDOP1.660
FIELDOP1.661
! Set model_flag and reset UNPACK if DUMP FIELDOP1.662
If(pp_fixhd(5).ne.3) then FIELDOP1.663
FIELDOP1.664
model_flag=.true. ! Model dump FIELDOP1.665
write(*,*)'Model dump - UNPACK set true ' FIELDOP1.666
Else FIELDOP1.667
FIELDOP1.668
model_flag=.false. ! Fieldsfile FIELDOP1.669
End if FIELDOP1.670
FIELDOP1.671
! Find maximum field length to dimension array 'field' holding FIELDOP1.672
! the data for each field - prevents writing outside bounds FIELDOP1.673
! of array. FIELDOP1.674
max_len=0 FIELDOP1.675
Do i =1,len1 UIE0F403.116
FIELDOP1.677
If (model_flag) then FIELDOP1.678
FIELDOP1.679
If (lookup(lblrec,i).gt.max_len) then FIELDOP1.680
max_len =lookup(lblrec,i) FIELDOP1.681
End if FIELDOP1.682
FIELDOP1.683
! For datafiles 1 and 2, check that number of values in FIELDOP1.684
! field agrees. FIELDOP1.685
Else FIELDOP1.686
FIELDOP1.687
len_i =lookup(lbrow,i) *lookup(lbnpt,i)+lookup(lbext,i) FIELDOP1.688
If (len_i.gt.max_len) then FIELDOP1.689
max_len =len_i FIELDOP1.690
End if FIELDOP1.691
FIELDOP1.692
End if FIELDOP1.693
FIELDOP1.694
End do FIELDOP1.695
FIELDOP1.696
! Set the length of data record (see above). FIELDOP1.697
! Loop thro all the entries within the field FIELDOP1.698
Do i=1,len1 UIE0F403.117
FIELDOP1.708
ignore=.false. UIE0F403.118
If (pos1(i) .eq. -1) ignore=.true. UIE0F403.119
FIELDOP1.711
If (model_flag) then UIE0F403.120
num_values =lookup(lblrec,i) UIE0F403.121
FIELDOP1.715
Else FIELDOP1.718
num_values =lookup(lbrow,i) *lookup(lbnpt,i) UIE0F403.122
& +lookup(lbext,i) UIE0F403.123
End if FIELDOP1.735
FIELDOP1.736
If (lookup(lbext,i) .gt. 0) then UIE0F403.124
FIELDOP1.740
! got some extra data; check to see that we don't have FIELDOP1.741
! packing if we have extra data.... FIELDOP1.742
If(lookup(lbrow,i)*lookup(lbnpt,i)+ UIE0F403.125
FIELDOP1.744
& lookup(lbext,i) .ne. lookup(lblrec,i)) then UIE0F403.126
cmessage='fieldop_main: Packing of extra data not supported' FIELDOP1.746
icode=1 FIELDOP1.747
return FIELDOP1.748
FIELDOP1.749
End if FIELDOP1.750
End if FIELDOP1.751
FIELDOP1.752
idim =((num_values+1)/2) *2 FIELDOP1.761
entry_no =i UIE0F403.127
entry_no2 =pos2(i) FIELDOP1.767
FIELDOP1.769
! Alter data and validity times in lookup tables so that lookup(1) UIE0F403.128
! -> lookup(14) taken from second file rather than first if UIE0F403.129
! logical Tcopy is TRUE. UIE0F403.130
If (Tcopy) then UIE0F403.131
UIE0F403.132
If (.not.model_flag) then UIE0F403.133
! Copy lookup tables from lookup2 to lookup. UIE0F403.134
If (entry_no2 .ne. -1) then UIE0F403.135
Do j=1,14 UIE0F403.136
lookup(j,entry_no) = lookup2(j,entry_no2) UIE0F403.137
End do UIE0F403.138
Else UIE0F403.139
cmessage='ERROR with -T option as fields dont match' UIE0F403.140
call abort UIE0F403.141
End if UIE0F403.142
Else UIE0F403.143
Do j=1,14 UIE0F403.144
lookup(j,entry_no) = lookup2(j,1) UIE0F403.145
End do UIE0F403.146
End if UIE0F403.147
UIE0F403.148
call setpos(pp_unit_out,pp_fixhd(150)+(i-1) UIE0F403.149
& *len1_lookup-1,icode) UIE0F403.150
call buffout(pp_unit_out,lookup(1,i),pp_fixhd(151) UIE0F403.151
& ,len_io,a_io) UIE0F403.152
UIE0F403.153
! Check for I/O errors UIE0F403.154
If (a_io .ne. -1.0 .or. len_io .ne. pp_fixhd(151)) then UIE0F403.155
UIE0F403.156
call ioerror('buffer out of lookup table',a_io,len_io, UIE0F403.157
* pp_fixhd(151)) UIE0F403.158
cmessage='FIELDOP: I/O error' UIE0F403.159
icode=25 UIE0F403.160
return UIE0F403.161
End if UIE0F403.162
End if FIELDOP1.771
FIELDOP1.773
call read_write(num_values, ! IN Length of packed field UIE0F403.163
& pp_unit1, ! IN Unit no of 1st I/P file. FIELDOP1.777
& pp_unit2, ! IN Unit no of 2nd I/P file. FIELDOP1.778
& len1_lookup, ! IN 1st dim of lookup of file1. FIELDOP1.779
& pp_len2_lookup, ! IN 2nd dim of lookup of file1. FIELDOP1.780
& len_fixhd, FIELDOP1.781
& pp_fixhd, ! IN Fixed header of file1. FIELDOP1.782
& lookup, ! IN Lookup table file1. FIELDOP1.783
& ! (integer part used). FIELDOP1.784
& pp_fixhd2, ! IN Fixed header of file2. FIELDOP1.785
& lookup2, ! IN Lookup table file2. FIELDOP1.786
& ! (Integer part used). FIELDOP1.787
& lookup2, ! IN (Real part used). FIELDOP1.788
& len1_lookup2, ! IN 1st dim of lookup of file2. FIELDOP1.789
& pp_len2_lookup2,! IN 2nd dim of lookup of file1. FIELDOP1.790
& op, ! IN Operation type. FIELDOP1.791
& lookup, ! IN Lookup table file1. FIELDOP1.792
& ! (real part used). FIELDOP1.793
& entry_no, ! IN Posn of field in lookup1. FIELDOP1.794
& entry_no2, ! IN Posn of field in lookup2. FIELDOP1.795
& data_add2, ! IN Start address of data file2. FIELDOP1.796
& data_add1, ! IN Start address of data file1. FIELDOP1.797
& model_flag, ! IN TRUE (dump).FALSE (fieldsfile) FIELDOP1.798
& nfields, UIE0F403.164
& tfields, UIE0F403.165
& llev, UIE0F403.166
& ignore, UIE0F403.167
& pp_unit_out, ! IN Unit no. of O/P file. FIELDOP1.799
& max_len, FIELDOP1.800
& divisor, ! IN Integer divisor if specified. FIELDOP1.802
& lookup(63,entry_no), UIE0F403.168
& l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,l11,l12, UIE0F403.169
& l13,l14,l15,l16,l17,l18,l19,l20, UIE0F403.170
& stash1,stash2,stash3,stash4,stash5, FIELDOP1.803
& stash6,stash7,stash8,stash9,stash10, FIELDOP1.804
& stash11,stash12,stash13,stash14,stash15, FIELDOP1.805
& stash16,stash17,stash18,stash19,stash20, FIELDOP1.806
*CALL ARGPPX FIELDOP1.807
& icode,cmessage) ! Error code/message. FIELDOP1.808
FIELDOP1.809
If(icode.ne.0) then FIELDOP1.810
return FIELDOP1.811
End if FIELDOP1.812
FIELDOP1.813
End do ! i FIELDOP1.814
FIELDOP1.815
RETURN FIELDOP1.816
END FIELDOP1.817
FIELDOP1.818
! FIELDOP1.819
! Subroutine interface: FIELDOP1.820
subroutine read_write(idim, 2,12FIELDOP1.821
& pp_unit1, FIELDOP1.823
& pp_unit2, FIELDOP1.824
& len1_lookup, FIELDOP1.825
& len2_lookup, UIE0F403.314
& len_fixhd, FIELDOP1.827
& fixhd, UIE0F403.315
& lookup, FIELDOP1.829
& fixhd2, UIE0F403.316
& lookup2, FIELDOP1.831
& rookup2, FIELDOP1.832
& len1_lookup2, FIELDOP1.833
& len2_lookup2, UIE0F403.317
& op, FIELDOP1.835
& rookup, FIELDOP1.836
& entry_no, FIELDOP1.837
& entry_no2, FIELDOP1.838
& data_add2, FIELDOP1.839
& data_add1, FIELDOP1.840
& model_flag, FIELDOP1.841
& nfields, UIE0F403.318
& tfields, UIE0F403.319
& llev, UIE0F403.320
& ignore, UIE0F403.321
& pp_unit_out, FIELDOP1.842
& max_len, FIELDOP1.843
& divisor, FIELDOP1.845
& amdi, UIE0F403.322
& l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,l11,l12, UIE0F403.323
& l13,l14,l15,l16,l17,l18,l19,l20, UIE0F403.324
& stash1,stash2,stash3,stash4,stash5, FIELDOP1.846
& stash6,stash7,stash8,stash9,stash10, FIELDOP1.847
& stash11,stash12,stash13,stash14,stash15, FIELDOP1.848
& stash16,stash17,stash18,stash19,stash20, FIELDOP1.849
*CALL ARGPPX FIELDOP1.850
& icode,cmessage) FIELDOP1.851
FIELDOP1.852
IMPLICIT NONE FIELDOP1.853
! FIELDOP1.854
! Description: FIELDOP1.855
! Accesses the data (packed or unpacked) from one or two model FIELDOP1.856
! dumps or direct access fieldsfiles and write out to a new file FIELDOP1.857
! the difference, sum or product of the data values. (if a single FIELDOP1.858
! datafile is read the data is divided by an integer). The output file FIELDOP1.859
! is a copy of the first input file with the fields overwritten by the FIELDOP1.860
! differenced/meaned etc data. FIELDOP1.861
! FIELDOP1.862
! Method: FIELDOP1.863
! FIELDOP1.864
! Current Code Owner: I Edmond FIELDOP1.865
! FIELDOP1.866
! History: FIELDOP1.867
! Version Date Comment FIELDOP1.868
! ------- ---- ------- FIELDOP1.869
! <version> <date> Original code. <Your name> FIELDOP1.870
! FIELDOP1.871
! Code Description: FIELDOP1.872
! Language: FORTRAN 77 + common extensions. FIELDOP1.873
! This code is written to UMDP3 v6 programming standards. FIELDOP1.874
! FIELDOP1.875
! System component covered: <appropriate code> FIELDOP1.876
! System Task: <appropriate code> FIELDOP1.877
! FIELDOP1.878
! Declarations: FIELDOP1.879
! These are of the form:- FIELDOP1.880
! INTEGER ExampleVariable !Description of variable FIELDOP1.881
! FIELDOP1.882
! 1.0 Global variables (*CALLed COMDECKs etc...): FIELDOP1.883
*CALL CSUBMODL FIELDOP1.884
*CALL CPPXREF FIELDOP1.885
*CALL PPXLOOK FIELDOP1.886
*CALL CLOOKADD FIELDOP1.887
FIELDOP1.888
! Subroutine arguments FIELDOP1.889
! Scalar arguments with intent(in): FIELDOP1.890
INTEGER FIELDOP1.891
& pp_unit1, ! unit no of required fieldsfile/dump FIELDOP1.892
& pp_unit2, ! unit no of required fieldsfile/dump FIELDOP1.893
& pp_unit_out, ! unit no of output file FIELDOP1.894
& len_fixhd, FIELDOP1.896
& idim, ! num_values rounded to an even no FIELDOP1.897
& ! used to dimension the output array FIELDOP1.898
& data_add1, ! The word address of the data. FIELDOP1.899
& data_add2, ! The word address of the data. FIELDOP1.900
& len1_lookup, ! First dimension of the lookup FIELDOP1.901
& len1_lookup2, ! First dimension of the lookup FIELDOP1.902
& len2_lookup, ! Size of the lookup on the file UIE0F403.325
& len2_lookup2, ! Size of the lookup on the file UIE0F403.326
& max_len, FIELDOP1.905
& comp_accry1, UIE0F403.327
& comp_accry2, UIE0F403.328
& entry_no, ! Lookup entry no of the Field. FIELDOP1.906
& entry_no2, ! Lookup entry no of the Field. FIELDOP1.907
& stash1,stash2,stash3,stash4,stash5, FIELDOP1.908
& stash6,stash7,stash8,stash9,stash10, FIELDOP1.909
& stash11,stash12,stash13,stash14,stash15, FIELDOP1.910
& stash16,stash17,stash18,stash19,stash20, FIELDOP1.911
& l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,l11,l12, UIE0F403.329
& l13,l14,l15,l16,l17,l18,l19,l20, UIE0F403.330
& divisor, FIELDOP1.912
& exppxi FIELDOP1.913
FIELDOP1.914
REAL FIELDOP1.915
& rookup(len1_lookup,len2_lookup), ! Real lookup UIE0F403.331
& rookup2(len1_lookup2,len2_lookup2) ! Real lookup UIE0F403.332
&,amdi UIE0F403.333
FIELDOP1.918
LOGICAL FIELDOP1.919
& model_flag !IN True => dumps, False => fieldsfile FIELDOP1.921
FIELDOP1.922
! Array arguments with intent(in): FIELDOP1.923
INTEGER FIELDOP1.924
& fixhd(len_fixhd), ! fixed header (file1) UIE0F403.334
& fixhd2(len_fixhd), ! fixed header (file2) UIE0F403.335
& lookup(len1_lookup,len2_lookup), ! integer lookup (file1) UIE0F403.336
& lookup2(len1_lookup2,len2_lookup2) ! integer lookup (file2) UIE0F403.337
FIELDOP1.929
CHARACTER FIELDOP1.930
& op*(8) FIELDOP1.931
FIELDOP1.932
CHARACTER FIELDOP1.933
& exppxc*(36) FIELDOP1.934
FIELDOP1.935
! ErrorStatus FIELDOP1.936
INTEGER FIELDOP1.937
& icode FIELDOP1.938
FIELDOP1.939
CHARACTER FIELDOP1.940
& cmessage*80 FIELDOP1.941
FIELDOP1.942
! Local parameters: FIELDOP1.943
INTEGER max_len_ilabel ! max length of INT part of pp header FIELDOP1.944
PARAMETER(max_len_ilabel=45) FIELDOP1.945
FIELDOP1.946
INTEGER max_len_rlabel ! max length of REAL part of pp header FIELDOP1.947
PARAMETER(max_len_rlabel=32) FIELDOP1.948
FIELDOP1.949
! Local scalars: FIELDOP1.950
INTEGER FIELDOP1.951
& i, ! local counter FIELDOP1.952
& iwa, ! Word address in call setpos (file1). FIELDOP1.953
& iwa2, ! Word address in call setpos (file2). FIELDOP1.954
& n_rows_out, ! No of rows of data in field. FIELDOP1.955
& n_cols_out, ! No. of columns of data in field. FIELDOP1.956
& len_ilabel, ! number of values in ilabel FIELDOP1.957
& len_rlabel ! number of values in rlabel FIELDOP1.958
FIELDOP1.959
LOGICAL UIE0F403.338
& packed ! indicates whether the data is packed UIE0F403.339
&,cont ! indicates whether to operate on field UIE0F403.340
&,nfields UIE0F403.341
&,tfields UIE0F403.342
&,llev UIE0F403.343
&,ignore UIE0F403.344
&,lop UIE0F403.345
FIELDOP1.961
! Local dynamic arrays: FIELDOP1.962
INTEGER FIELDOP1.963
& ilabel(max_len_ilabel), ! holds integer part of lookup FIELDOP1.964
& ilabel2(max_len_ilabel) ! holds integer part of lookup FIELDOP1.965
FIELDOP1.966
REAL FIELDOP1.967
& field(max_len), ! array holding data FIELDOP1.968
& field0(max_len), ! array holding data FIELDOP1.969
& rlabel(max_len_rlabel), ! holds real part of lookup FIELDOP1.970
& rlabel2(max_len_rlabel) ! holds real part of lookup FIELDOP1.971
! Function & Subroutine calls: FIELDOP1.973
External readff,writeff FIELDOP1.974
FIELDOP1.975
!- End of header FIELDOP1.976
comp_accry1=0 UIE0F403.346
comp_accry2=0 UIE0F403.347
! Fields with stashcodes are written directly to output FIELDOP1.979
! fieldsfile or dump. FIELDOP1.980
If ((((lookup(42,entry_no).eq.stash1).or. UIE0F403.348
& (lookup(42,entry_no).eq.stash2) UIE0F403.349
& .or.(lookup(42,entry_no).eq.stash3).or. UIE0F403.350
& (lookup(42,entry_no).eq.stash4) UIE0F403.351
& .or.(lookup(42,entry_no).eq.stash5).or. UIE0F403.352
& (lookup(42,entry_no).eq.stash6) UIE0F403.353
& .or.(lookup(42,entry_no).eq.stash7).or. UIE0F403.354
& (lookup(42,entry_no).eq.stash8) UIE0F403.355
& .or.(lookup(42,entry_no).eq.stash9).or. UIE0F403.356
& (lookup(42,entry_no).eq.stash10) UIE0F403.357
& .or.(lookup(42,entry_no).eq.stash11).or. UIE0F403.358
& (lookup(42,entry_no).eq.stash12) UIE0F403.359
& .or.(lookup(42,entry_no).eq.stash13).or. UIE0F403.360
& (lookup(42,entry_no).eq.stash14) UIE0F403.361
& .or.(lookup(42,entry_no).eq.stash15).or. UIE0F403.362
& (lookup(42,entry_no).eq.stash16) UIE0F403.363
& .or.(lookup(42,entry_no).eq.stash17).or. UIE0F403.364
& (lookup(42,entry_no).eq.stash18) UIE0F403.365
& .or.(lookup(42,entry_no).eq.stash19).or. UIE0F403.366
& (lookup(42,entry_no).eq.stash20)) UIE0F403.367
& .and.(nfields)) UIE0F403.368
& .or. UIE0F403.369
& (.not.((lookup(42,entry_no).eq.stash1).or. UIE0F403.370
& (lookup(42,entry_no).eq.stash2) FIELDOP1.982
& .or.(lookup(42,entry_no).eq.stash3).or. FIELDOP1.983
& (lookup(42,entry_no).eq.stash4) FIELDOP1.984
& .or.(lookup(42,entry_no).eq.stash5).or. FIELDOP1.985
& (lookup(42,entry_no).eq.stash6) FIELDOP1.986
& .or.(lookup(42,entry_no).eq.stash7).or. FIELDOP1.987
& (lookup(42,entry_no).eq.stash8) FIELDOP1.988
& .or.(lookup(42,entry_no).eq.stash9).or. FIELDOP1.989
& (lookup(42,entry_no).eq.stash10) FIELDOP1.990
& .or.(lookup(42,entry_no).eq.stash11).or. FIELDOP1.991
& (lookup(42,entry_no).eq.stash12) FIELDOP1.992
& .or.(lookup(42,entry_no).eq.stash13).or. FIELDOP1.993
& (lookup(42,entry_no).eq.stash14) FIELDOP1.994
& .or.(lookup(42,entry_no).eq.stash15).or. FIELDOP1.995
& (lookup(42,entry_no).eq.stash16) FIELDOP1.996
& .or.(lookup(42,entry_no).eq.stash17).or. FIELDOP1.997
& (lookup(42,entry_no).eq.stash18) FIELDOP1.998
& .or.(lookup(42,entry_no).eq.stash19).or. FIELDOP1.999
& (lookup(42,entry_no).eq.stash20)) FIELDOP1.1000
& .and.(tfields)) UIE0F403.371
& .or.(ignore)) UIE0F403.372
&then FIELDOP1.1001
UIE0F403.373
write(*,*)'FIELD NO.',entry_no,'DIRECTLY TRANSFERED' FIELDOP1.1002
lop=.false. UIE0F403.374
UIE0F403.375
Else if(fixhd(5).eq.3.and.lookup(42,entry_no).eq.30)then UDG1F405.1563
write(*,*)'FIELD NO.',entry_no, UDG1F405.1564
& 'LAND-SEA MASK: DIRECTLY TRANSFERED' UDG1F405.1565
lop=.false. UDG1F405.1566
Else UIE0F403.376
UIE0F403.377
if (((llev .and. UIE0F403.378
& ((lookup(33,entry_no).eq.l1).or. UIE0F403.379
& (lookup(33,entry_no).eq.l2) UIE0F403.380
& .or.(lookup(33,entry_no).eq.l3).or. UIE0F403.381
& (lookup(33,entry_no).eq.l4) UIE0F403.382
& .or.(lookup(33,entry_no).eq.l5).or. UIE0F403.383
& (lookup(33,entry_no).eq.l6) UIE0F403.384
& .or.(lookup(33,entry_no).eq.l7).or. UIE0F403.385
& (lookup(33,entry_no).eq.l8) UIE0F403.386
& .or.(lookup(33,entry_no).eq.l9).or. UIE0F403.387
& (lookup(33,entry_no).eq.l10) UIE0F403.388
& .or.(lookup(33,entry_no).eq.l11).or. UIE0F403.389
& (lookup(33,entry_no).eq.l12) UIE0F403.390
& .or.(lookup(33,entry_no).eq.l13).or. UIE0F403.391
& (lookup(33,entry_no).eq.l14) UIE0F403.392
& .or.(lookup(33,entry_no).eq.l15).or. UIE0F403.393
& (lookup(33,entry_no).eq.l16) UIE0F403.394
& .or.(lookup(33,entry_no).eq.l17).or. UIE0F403.395
& (lookup(33,entry_no).eq.l18) UIE0F403.396
& .or.(lookup(33,entry_no).eq.l19).or. UIE0F403.397
& (lookup(33,entry_no).eq.l20))).and. UIE0F403.398
& (lookup(33,entry_no).ne.0)) .or. (.not.llev))then UIE0F403.399
UIE0F403.400
write(*,*)'FIELD NO.',entry_no,'OPERATED ON' UIE0F403.401
lop=.true. UIE0F403.402
UIE0F403.403
UIE0F403.404
Else FIELDOP1.1003
write(*,*)'FIELD NO.',entry_no,'DIRECTLY TRANSFERED' UIE0F403.405
lop=.false. UIE0F403.406
UIE0F403.407
End if UIE0F403.408
UIE0F403.409
End if UIE0F403.410
UIE0F403.411
! Fieldsfiles contain packed data which when expanded, UIE0F403.412
! operated upon and repacked occupy a different amount of UIE0F403.413
! space. It is therefore necessary to write out data in a UIE0F403.414
! fieldsfile to the new addresses even although only some UIE0F403.415
! of the fields may be changed. UIE0F403.416
If ((lop) .or. (fixhd(5).eq.3)) then UIE0F403.417
FIELDOP1.1004
Do i=1,idim ! field is initialised. FIELDOP1.1005
field(i) =0.0 FIELDOP1.1006
End do FIELDOP1.1007
FIELDOP1.1008
packed=.false. FIELDOP1.1009
FIELDOP1.1010
! Access the 1st fieldsfile/dump. FIELDOP1.1011
call readff(pp_unit1, ! IN Unit no. FIELDOP1.1012
& field, ! OUT Data field. FIELDOP1.1013
& idim, ! IN Size of data field (rounded). FIELDOP1.1014
& entry_no, ! IN position of field in lookup. FIELDOP1.1015
& ilabel, ! OUT Integer part of lookup. FIELDOP1.1016
& rlabel, ! OUT Real part of lookup. FIELDOP1.1017
& len2_lookup, ! IN UIE0F403.418
& len1_lookup, ! IN FIELDOP1.1019
& len_fixhd, FIELDOP1.1020
& fixhd, ! IN Fixed header UIE0F403.419
& lookup, ! IN Integer part of lookup. FIELDOP1.1022
& rookup, ! IN Real part of lookup. FIELDOP1.1023
& data_add1, ! IN Start address of data. FIELDOP1.1024
& model_flag, ! IN TRUE -dump, FALSE -fieldsfile FIELDOP1.1025
& max_len_ilabel, ! IN FIELDOP1.1026
& max_len_rlabel, ! IN FIELDOP1.1027
& max_len, FIELDOP1.1028
& comp_accry1, ! OUT Packing accuracy of field UIE0F403.420
& len_ilabel, ! IN FIELDOP1.1029
& len_rlabel, ! IN FIELDOP1.1030
& iwa, ! OUT Word address of data field FIELDOP1.1031
& ! in call to setpos. FIELDOP1.1032
& icode,cmessage) ! IN FIELDOP1.1033
FIELDOP1.1034
If (lop) then ! Arithmetic operation performed on field. UIE0F403.421
UIE0F403.422
If (op .ne. 'idiv ') then FIELDOP1.1035
FIELDOP1.1036
Do i=1,idim FIELDOP1.1037
FIELDOP1.1038
field0(i) =field(i) ! Write data from file1 to data0. FIELDOP1.1039
field(i) =0.0 FIELDOP1.1040
FIELDOP1.1041
End do ! i FIELDOP1.1042
FIELDOP1.1043
! Access the 2nd fieldsfile/dump. FIELDOP1.1044
call readff(pp_unit2, ! IN Unit no. FIELDOP1.1045
& field, ! OUT Data field corresponding FIELDOP1.1046
& ! to field accessed in file1. FIELDOP1.1047
& idim, ! IN Size of data field (rounded) FIELDOP1.1048
& entry_no2, ! IN position of field in lookup2 FIELDOP1.1049
& ilabel2, ! OUT Integer part of lookup. FIELDOP1.1050
& rlabel2, ! OUT Real part of lookup. FIELDOP1.1051
& len2_lookup2, ! IN UIE0F403.423
& len1_lookup2, ! IN FIELDOP1.1053
& len_fixhd, FIELDOP1.1054
& fixhd2, ! IN Fixed header UIE0F403.424
& lookup2, ! IN Integer part of lookup. FIELDOP1.1056
& rookup2, ! IN Real part of lookup. FIELDOP1.1057
& data_add2, ! IN Start address of data. FIELDOP1.1058
& model_flag, ! IN TRUE dump, FALSE fieldsfile FIELDOP1.1059
& max_len_ilabel, ! IN FIELDOP1.1060
& max_len_rlabel, ! IN FIELDOP1.1061
& max_len, ! IN Max no of points of a field UIE0F403.425
& comp_accry2, ! OUT Packing accuracy of field UIE0F403.426
& len_ilabel, ! IN FIELDOP1.1063
& len_rlabel, ! IN FIELDOP1.1064
& iwa2, ! OUT Word address of data field FIELDOP1.1065
& ! in call to setpos. FIELDOP1.1066
& icode,cmessage) ! IN FIELDOP1.1067
FIELDOP1.1068
! The data has now been read in and has 1) read in as packed FIELDOP1.1069
! and then un-packed or 2) The data was never packed at all. FIELDOP1.1070
! If packed field will have lblrec/2 values if a DUMP and FIELDOP1.1071
! LBLREC values if a pp_file. If the data is not packed field FIELDOP1.1072
! will have the no of data points length lbrow*lbnpt+lbext if FIELDOP1.1073
! a pp_file and lblrec if a dump file. FIELDOP1.1074
FIELDOP1.1075
! For a dump lblrec will hold origonal no of data points. FIELDOP1.1076
! For a pp_file lblrec will hold the no of CRAY words needed FIELDOP1.1077
! to hold the data (if un-packed also no of data points) FIELDOP1.1078
FIELDOP1.1079
! Difference, sum or multiply the data in fields. FIELDOP1.1080
If (op .eq. 'subtract') then FIELDOP1.1081
write(*,*)'subtract',entry_no UIE0F403.427
Do i = 1,idim FIELDOP1.1082
If (lookup(data_type,entry_no).eq.3) then FIELDOP1.1083
field(i) = field(i) FIELDOP1.1084
Else FIELDOP1.1085
If (field(i).ne.amdi) then UIE0F403.428
field(i) = field0(i) - field(i) FIELDOP1.1086
End if FIELDOP1.1087
End if UIE0F403.429
End do FIELDOP1.1088
FIELDOP1.1089
Else if (op .eq. 'add ') then UIE0F403.430
Do i = 1,idim FIELDOP1.1091
if (lookup(data_type,entry_no).eq.3) then FIELDOP1.1092
field(i) = field(i) FIELDOP1.1093
Else FIELDOP1.1094
If (field(i).ne.amdi) then UIE0F403.431
field(i) = field0(i) + field(i) FIELDOP1.1095
End if FIELDOP1.1096
End if UIE0F403.432
End do FIELDOP1.1097
FIELDOP1.1098
Else if (op .eq. 'multiply') then UIE0F403.433
Do i = 1,idim FIELDOP1.1100
If (lookup(data_type,entry_no).eq.3) then FIELDOP1.1101
field(i) = field(i) FIELDOP1.1102
Else FIELDOP1.1103
If (field(i).ne.amdi) then UIE0F403.434
field(i) = field0(i) * field(i) FIELDOP1.1104
End if FIELDOP1.1105
End if UIE0F403.435
End do FIELDOP1.1106
FIELDOP1.1107
Else FIELDOP1.1108
FIELDOP1.1109
write(6,*)'Not a valid operation' FIELDOP1.1110
call abort FIELDOP1.1111
FIELDOP1.1112
End if FIELDOP1.1113
Else FIELDOP1.1114
FIELDOP1.1115
! Divide data in field from a single input file by an integer. FIELDOP1.1116
Do i = 1,idim FIELDOP1.1117
If (lookup(data_type,entry_no).eq.3) then FIELDOP1.1118
field(i) = field(i) FIELDOP1.1119
Else FIELDOP1.1120
If (field(i).ne.amdi) then UIE0F403.436
field(i) = field(i) / divisor FIELDOP1.1121
End if FIELDOP1.1122
End if UIE0F403.437
End do FIELDOP1.1123
FIELDOP1.1124
End if FIELDOP1.1125
FIELDOP1.1126
End if UIE0F403.438
UIE0F403.439
If(icode.ne.0) return FIELDOP1.1127
FIELDOP1.1128
n_rows_out=lookup(18,entry_no) FIELDOP1.1129
n_cols_out=lookup(19,entry_no) FIELDOP1.1130
FIELDOP1.1131
! Write data to output dump/fieldsfile. Data written to original FIELDOP1.1132
! positions in 1st file. FIELDOP1.1133
call writeff(pp_unit_out, ! IN Unit no of output file. FIELDOP1.1134
& field, ! IN Output data after arith op. FIELDOP1.1135
& idim, ! IN Size of data field (rounded). FIELDOP1.1136
& entry_no, ! IN pos. of field in lookup table. FIELDOP1.1137
& data_add1, UIE0F403.440
& lookup, ! IN FIELDOP1.1138
& len_fixhd, FIELDOP1.1139
& fixhd, ! IN UIE0F403.441
& len2_lookup, ! IN UIE0F403.442
& len1_lookup, ! IN FIELDOP1.1142
& n_rows_out, ! IN FIELDOP1.1143
& n_cols_out, ! IN FIELDOP1.1144
& packed, ! IN FALSE - unpacked data FIELDOP1.1145
& max_len, ! IN Max no of points of a field in f UIE0F403.443
& comp_accry1, ! IN accuracy at which field packed UIE0F403.444
& op, ! IN Operation type. FIELDOP1.1148
*CALL ARGPPX FIELDOP1.1149
& icode,cmessage) ! IN FIELDOP1.1150
FIELDOP1.1151
UIE0F403.445
Endif UIE0F403.446
FIELDOP1.1153
RETURN FIELDOP1.1154
END FIELDOP1.1155
FIELDOP1.1156
! FIELDOP1.1157
! Subroutine interface: FIELDOP1.1158
subroutine writeff(pp_unit_out, 1,16FIELDOP1.1159
& field, FIELDOP1.1160
& idim, FIELDOP1.1161
& entry_no, FIELDOP1.1162
& data_add, UIE0F403.478
& lookup, FIELDOP1.1163
& len_fixhd, FIELDOP1.1164
& fixhd, UIE0F403.479
& len2_lookup, UIE0F403.480
& len1_lookup, FIELDOP1.1167
& n_rows_out, FIELDOP1.1168
& n_cols_out, FIELDOP1.1169
& packed, FIELDOP1.1170
& max_len, FIELDOP1.1171
& comp_accry, UIE0F403.481
& op, FIELDOP1.1173
*CALL ARGPPX FIELDOP1.1174
& icode,cmessage) FIELDOP1.1175
FIELDOP1.1176
IMPLICIT NONE FIELDOP1.1177
! FIELDOP1.1178
! FIELDOP1.1179
! Description: To ouput a field to a UM dump or fieldsfile, with the FIELDOP1.1180
! data written in packed (wgdos,grib or cray 32 bits) or FIELDOP1.1181
! unpacked form. FIELDOP1.1182
! Method: FIELDOP1.1183
! FIELDOP1.1184
! Current Code Owner: I Edmond FIELDOP1.1185
! FIELDOP1.1186
! History: FIELDOP1.1187
! Version Date Comment FIELDOP1.1188
! ------- ---- ------- FIELDOP1.1189
! <version> <date> Original code. <Your name> FIELDOP1.1190
! FIELDOP1.1191
! Code Description: FIELDOP1.1192
! Language: FORTRAN 77 + common extensions. FIELDOP1.1193
! This code is written to UMDP3 v6 programming standards. FIELDOP1.1194
! FIELDOP1.1195
! System component covered: <appropriate code> FIELDOP1.1196
! System Task: <appropriate code> FIELDOP1.1197
! FIELDOP1.1198
! Declarations: FIELDOP1.1199
! These are of the form:- FIELDOP1.1200
! INTEGER ExampleVariable !Description of variable FIELDOP1.1201
! FIELDOP1.1202
! 1.0 Global variables (*CALLed COMDECKs etc...): FIELDOP1.1203
*CALL CSUBMODL FIELDOP1.1204
*CALL CPPXREF FIELDOP1.1205
*CALL PPXLOOK FIELDOP1.1206
*CALL CLOOKADD FIELDOP1.1207
*CALL C_MDI FIELDOP1.1208
FIELDOP1.1209
! Subroutine arguments FIELDOP1.1210
! Scalar arguments with intent(in): FIELDOP1.1211
INTEGER FIELDOP1.1212
& n_rows_out, UIE0F403.482
& n_cols_out, UIE0F403.483
& len_fixhd, FIELDOP1.1215
& pp_unit_out, UIE0F403.484
& len2_lookup, UIE0F403.485
& len1_lookup, UIE0F403.486
& entry_no, UIE0F403.487
& grib_packing, FIELDOP1.1220
& max_len, FIELDOP1.1222
& comp_accry, UIE0F403.488
& idim, UIE0F403.489
& data_add, UIE0F403.490
& exppxi FIELDOP1.1224
FIELDOP1.1225
CHARACTER FIELDOP1.1226
& op*(8) FIELDOP1.1227
FIELDOP1.1228
CHARACTER FIELDOP1.1229
& exppxc*(36) FIELDOP1.1230
FIELDOP1.1231
LOGICAL FIELDOP1.1232
& packed FIELDOP1.1233
FIELDOP1.1234
! Array arguments with intent(in): FIELDOP1.1235
INTEGER FIELDOP1.1236
& lookup(len1_lookup,len2_lookup), UIE0F403.491
& fixhd(len_fixhd), UIE0F403.492
& ifield(max_len) FIELDOP1.1239
FIELDOP1.1240
REAL FIELDOP1.1241
& field(max_len) FIELDOP1.1242
FIELDOP1.1243
! ErrorStatus FIELDOP1.1244
INTEGER FIELDOP1.1245
& icode FIELDOP1.1246
FIELDOP1.1247
REAL FIELDOP1.1248
& A FIELDOP1.1249
FIELDOP1.1250
CHARACTER FIELDOP1.1251
& cmessage*80 FIELDOP1.1252
FIELDOP1.1253
! Local scalars: FIELDOP1.1254
INTEGER FIELDOP1.1255
& comp_accrcy, ! FIELDOP1.1256
& num_words, ! FIELDOP1.1257
& pack_type, ! Packing type N1 of LBPACK FIELDOP1.1258
& len_io, ! FIELDOP1.1259
& i ! FIELDOP1.1260
FIELDOP1.1261
! Function & Subroutine calls: FIELDOP1.1262
External writflds FIELDOP1.1263
FIELDOP1.1264
!- End of header FIELDOP1.1265
FIELDOP1.1266
icode = 0 FIELDOP1.1267
num_words = -99 FIELDOP1.1268
pack_type = MOD(lookup(lbpack,entry_no),10) FIELDOP1.1269
If (pack_type.gt.0) packed =.true. UIE0F403.493
FIELDOP1.1273
! Method of GRIB packing - use width method, with simple packing FIELDOP1.1274
! to be similar to the ECMWF MARS archive. FIELDOP1.1275
grib_packing=6 FIELDOP1.1276
FIELDOP1.1277
If((lookup(44,entry_no).lt.0) .or. FIELDOP1.1306
& (lookup(44,entry_no).gt.100)) then FIELDOP1.1307
FIELDOP1.1308
lookup(44,entry_no) = 0 FIELDOP1.1309
lookup(44,entry_no) = lookup(44,entry_no) + 1 FIELDOP1.1310
Else FIELDOP1.1311
FIELDOP1.1312
lookup(44,entry_no) = lookup(44,entry_no) + 1 FIELDOP1.1313
End if FIELDOP1.1314
FIELDOP1.1315
call setpos(pp_unit_out,fixhd(150)+(entry_no-1) UIE0F403.494
& *len1_lookup-1,icode) FIELDOP1.1317
call buffout(pp_unit_out,lookup(1,entry_no),fixhd(151) UIE0F403.495
& ,len_io,A) FIELDOP1.1319
FIELDOP1.1320
! Check for I/O errors FIELDOP1.1321
If (A .ne. -1.0 .or. len_io .ne. fixhd(151)) then UIE0F403.496
FIELDOP1.1323
call ioerror('buffer out of lookup table',A,len_io, FIELDOP1.1324
* fixhd(151)) UIE0F403.497
cmessage='FIELDOP: I/O error' FIELDOP1.1326
icode=25 FIELDOP1.1327
return FIELDOP1.1328
End if FIELDOP1.1329
FIELDOP1.1330
If (pack_type .eq.1)then FIELDOP1.1331
! Data packed using WGDOS method and written to O/P file. FIELDOP1.1333
call pp_file(field, ! IN Array to store expanded data UIE0F403.498
& idim, ! IN length of pp buffer (even no) UIE0F403.499
& num_words, ! IN No of 64bit words of data FIELDOP1.1337
& rmdi, ! IN Missing data FIELDOP1.1338
& comp_accry, ! IN PPXREF accuracy code. UIE0F403.500
& idim, ! IN length of pp buffer UIE0F403.501
& pp_unit_out, ! IN Unit no of O/P field. FIELDOP1.1341
& data_add, ! IN Word address of data (file1) UIE0F403.502
& n_cols_out, ! IN FIELDOP1.1344
& n_rows_out, ! IN UIE0F403.503
& packed, ! IN TRUE - packing required. FIELDOP1.1345
& pack_type, ! IN WGDOS packed data. FIELDOP1.1346
& lookup, ! IN lookup headers of file1. UIE0F403.504
& len1_lookup, ! IN UIE0F403.505
& len2_lookup, ! IN UIE0F403.506
& entry_no, ! IN UIE0F403.507
& icode,cmessage)! IN FIELDOP1.1347
FIELDOP1.1348
If (icode.gt.0) then FIELDOP1.1349
cmessage='FIELDOP : Error in PP_FILE' FIELDOP1.1350
call abort FIELDOP1.1351
End if FIELDOP1.1352
FIELDOP1.1353
Else if (pack_type.eq.3) then FIELDOP1.1354
FIELDOP1.1355
! Data compressed using the GRIB method, written to O/P file. FIELDOP1.1356
call grib_file(len1_lookup, ! IN FIELDOP1.1357
& len2_lookup, ! IN UIE0F403.508
& lookup, ! IN FIELDOP1.1359
& lookup, ! IN FIELDOP1.1360
& entry_no, ! IN Posn of field in lookup. FIELDOP1.1361
& field, ! IN Unpacked output data. FIELDOP1.1362
& max_len, ! IN Length of pp buffer FIELDOP1.1363
& max_len, ! IN FIELDOP1.1364
& num_words, ! IN No of 64bit words of data FIELDOP1.1365
& pp_unit_out, ! IN Unit no of O/P field. FIELDOP1.1366
& pp_unit_out, ! IN Word address of record. UIE0F403.509
& grib_packing, ! FIELDOP1.1368
& icode,cmessage) ! IN FIELDOP1.1369
FIELDOP1.1370
If (icode.gt.0) then FIELDOP1.1371
cmessage='FIELDOP : Error in GRIB_FILE' FIELDOP1.1372
call abort FIELDOP1.1373
End if FIELDOP1.1374
FIELDOP1.1375
Else if ((pack_type.eq.0).or.(pack_type.eq.2)) then UIE0F403.510
! Update lookup header data lengths and addressing for UIE0F403.511
! unpacked data in fieldsfile. UIE0F403.512
UIE0F403.513
If ((fixhd(5).eq.3).and.(pack_type.eq.0)) then UIE0F403.514
If (entry_no .eq. 1) then UIE0F403.515
lookup(29,entry_no) = data_add UIE0F403.516
Else UIE0F403.517
lookup(29,entry_no) = lookup(29,entry_no-1) UIE0F403.518
& + lookup(30,entry_no-1) UIE0F403.519
End If UIE0F403.520
lookup(40,entry_no) = lookup(29,entry_no) UIE0F403.521
End If UIE0F403.522
UIE0F403.523
If (lookup(data_type,entry_no) .eq. 2) then UIE0F403.524
FIELDOP1.1377
do i=1,idim FIELDOP1.1378
ifield(i)=field(i) FIELDOP1.1379
enddo FIELDOP1.1380
FIELDOP1.1381
call writflds(pp_unit_out,1,entry_no,lookup,len1_lookup, FIELDOP1.1382
& ifield,lookup(lblrec,entry_no),fixhd, UIE0F403.525
*CALL ARGPPX FIELDOP1.1384
& icode,cmessage) FIELDOP1.1385
Else UIE0F403.526
FIELDOP1.1386
! Data unpacked. UIE0F403.527
call writflds(pp_unit_out,1,entry_no,lookup,len1_lookup, FIELDOP1.1390
& field,lookup(lblrec,entry_no),fixhd, UIE0F403.528
*CALL ARGPPX FIELDOP1.1392
& icode,cmessage) FIELDOP1.1393
End If UIE0F403.529
FIELDOP1.1394
If (icode.gt.0) then FIELDOP1.1395
cmessage='FIELDOP : Error in MODEL DUMP' FIELDOP1.1396
call abort FIELDOP1.1397
End if FIELDOP1.1398
FIELDOP1.1399
End if FIELDOP1.1400
FIELDOP1.1401
call setpos(pp_unit_out,fixhd(150)+(entry_no-1) UIE0F403.530
& *len1_lookup-1,icode) UIE0F403.531
call buffout(pp_unit_out,lookup(1,entry_no),fixhd(151) UIE0F403.532
& ,len_io,A) UIE0F403.533
UIE0F403.534
! Check for I/O errors UIE0F403.535
If (A .ne. -1.0 .or. len_io .ne. fixhd(151)) then UIE0F403.536
UIE0F403.537
call ioerror('buffer out of lookup table',A,len_io, UIE0F403.538
* fixhd(151)) UIE0F403.539
cmessage='FIELDOP: I/O error' UIE0F403.540
icode=25 UIE0F403.541
return UIE0F403.542
End if UIE0F403.543
UIE0F403.544
If (op .eq. 'add ') then UIE0F403.545
UIE0F403.546
fixhd(15) = 100 UIE0F403.547
Else if (op .eq. 'subtract') then UIE0F403.548
UIE0F403.549
fixhd(15) = 200 UIE0F403.550
Else if (op .eq. 'multiply') then UIE0F403.551
UIE0F403.552
fixhd(15) = 300 UIE0F403.553
Else if (op .eq. 'idiv') then UIE0F403.554
UIE0F403.555
fixhd(15) = 400 UIE0F403.556
End if UIE0F403.557
UIE0F403.558
call setpos(pp_unit_out,0,icode) UIE0F403.559
call buffout(pp_unit_out,fixhd(1),len_fixhd,len_io,A) UIE0F403.560
UIE0F403.561
! Check for I/O errors UIE0F403.562
If(A .ne. -1.0 .or. len_io .ne. len_fixhd) then UIE0F403.563
call ioerror('buffer out of fixed length header',A,len_io UIE0F403.564
* ,len_fixhd) UIE0F403.565
cmessage='FIELDOP: I/O error' UIE0F403.566
icode=1 UIE0F403.567
return UIE0F403.568
End if UIE0F403.569
RETURN FIELDOP1.1402
END FIELDOP1.1403
FIELDOP1.1404
! FIELDOP1.1405
! Subroutine interface: FIELDOP1.1406
subroutine readff(pp_unit1, 6,7FIELDOP1.1407
& field, FIELDOP1.1408
& idim, FIELDOP1.1409
& entry_no, FIELDOP1.1410
& ilabel, FIELDOP1.1411
& rlabel, FIELDOP1.1412
& pp_len2_lookup, FIELDOP1.1413
& len1_lookup, FIELDOP1.1414
& len_fixhd, FIELDOP1.1415
& pp_fixhd, FIELDOP1.1416
& lookup, FIELDOP1.1417
& rookup, FIELDOP1.1418
& data_add1, FIELDOP1.1419
& model_flag, FIELDOP1.1420
& max_len_ilabel, FIELDOP1.1421
& max_len_rlabel, FIELDOP1.1422
& max_len, FIELDOP1.1423
& pppak, UIE0F403.309
& len_ilabel, FIELDOP1.1424
& len_rlabel, FIELDOP1.1425
& iwa, FIELDOP1.1426
& icode,cmessage) FIELDOP1.1427
IMPLICIT NONE FIELDOP1.1428
! FIELDOP1.1429
! FIELDOP1.1430
! Description: To read a direct access PP file. FIELDOP1.1431
! FIELDOP1.1432
! Method: FIELDOP1.1433
! FIELDOP1.1434
! Current Code Owner: I Edmond FIELDOP1.1435
! FIELDOP1.1436
! History: FIELDOP1.1437
! Version Date Comment FIELDOP1.1438
! ------- ---- ------- FIELDOP1.1439
! <version> <date> Original code. <Your name> FIELDOP1.1440
! FIELDOP1.1441
! Code Description: FIELDOP1.1442
! Language: FORTRAN 77 + common extensions. FIELDOP1.1443
! This code is written to UMDP3 v6 programming standards. FIELDOP1.1444
! FIELDOP1.1445
! System component covered: <appropriate code> FIELDOP1.1446
! System Task: <appropriate code> FIELDOP1.1447
! FIELDOP1.1448
! Declarations: FIELDOP1.1449
! These are of the form:- FIELDOP1.1450
! INTEGER ExampleVariable !Description of variable FIELDOP1.1451
! FIELDOP1.1452
! 1.0 Global variables (*CALLed COMDECKs etc...): FIELDOP1.1453
*CALL CLOOKADD FIELDOP1.1454
*CALL C_MDI FIELDOP1.1455
FIELDOP1.1456
! Subroutine arguments FIELDOP1.1457
! Scalar arguments with intent(in): FIELDOP1.1458
INTEGER FIELDOP1.1459
& len1_lookup, ! first dimension of the lookup FIELDOP1.1460
& pp_len2_lookup, ! secnd dimension of the lookup FIELDOP1.1461
& pp_unit1, ! unit no of required fieldsfile FIELDOP1.1462
& idim, ! Size of data field (rounded) FIELDOP1.1463
& max_len_rlabel, ! max sixe of rlabel FIELDOP1.1464
& max_len_ilabel, ! max sixe of ilabel FIELDOP1.1465
& max_len, FIELDOP1.1466
& data_add1, ! The word address of the data. FIELDOP1.1467
& entry_no, ! Lookup entry no of the Field. FIELDOP1.1468
& len_fixhd, FIELDOP1.1469
& lookup(len1_lookup,pp_len2_lookup) ! integer lookup FIELDOP1.1470
FIELDOP1.1471
REAL FIELDOP1.1472
& rookup(len1_lookup,pp_len2_lookup) ! real lookup FIELDOP1.1473
FIELDOP1.1474
LOGICAL FIELDOP1.1475
& model_flag ! True => Dump False =>Fieldsfile FIELDOP1.1476
FIELDOP1.1477
! Array arguments with intent(in): FIELDOP1.1478
INTEGER FIELDOP1.1479
& pp_fixhd(len_fixhd) ! fixed header FIELDOP1.1480
FIELDOP1.1481
! Scalar arguments with intent(out): FIELDOP1.1482
INTEGER FIELDOP1.1483
& len_rlabel, ! actual size of rlabel FIELDOP1.1484
& len_ilabel, ! actual size of ilabel UIE0F403.310
& pppak UIE0F403.311
FIELDOP1.1486
! Array arguments with intent(out): FIELDOP1.1487
INTEGER FIELDOP1.1488
& ilabel(max_len_ilabel) ! integer part of lookup FIELDOP1.1489
FIELDOP1.1490
REAL FIELDOP1.1491
& field(idim), ! array holding final output data. UIE0F403.312
& rlabel(max_len_rlabel) ! real part of lookup FIELDOP1.1493
FIELDOP1.1494
! ErrorStatus FIELDOP1.1495
INTEGER FIELDOP1.1496
& icode ! error code FIELDOP1.1497
FIELDOP1.1498
CHARACTER FIELDOP1.1499
& cmessage*80 ! error message FIELDOP1.1500
FIELDOP1.1501
! Local scalars: FIELDOP1.1502
INTEGER FIELDOP1.1503
& i,j, ! Local counters FIELDOP1.1504
& pack_type, ! packing type N1 of LBPACK FIELDOP1.1505
& num_cray_words, ! number of words for field FIELDOP1.1506
& nvals, ! number of points in a data field FIELDOP1.1507
& iwa, ! Word address in call setpos FIELDOP1.1508
& length_of_data, ! Length of a particular field FIELDOP1.1509
& addr, ! Address of a field in the data store FIELDOP1.1510
& pos_rlabel, ! position of first REAL in PPhdr FIELDOP1.1511
& pack_type_i ! packing type N1 of LBPACK FIELDOP1.1512
FIELDOP1.1513
REAL FIELDOP1.1514
& amdi ! Missing data indicator for lookup FIELDOP1.1515
FIELDOP1.1516
! Function & Subroutine calls: FIELDOP1.1517
External setpos,read_rec,ioerror,coex,integer_to_real FIELDOP1.1518
FIELDOP1.1519
!- End of header FIELDOP1.1520
FIELDOP1.1521
amdi=rookup(bmdi,entry_no) FIELDOP1.1522
If (amdi.ne.rmdi) write(*,*)' NON STANDARD MISSING DATA USED' FIELDOP1.1523
FIELDOP1.1524
pack_type = MOD(lookup(lbpack,entry_no),10) FIELDOP1.1525
FIELDOP1.1526
! Reading a model type dump FIELDOP1.1527
! A model dump has no direct addressing only relative. FIELDOP1.1528
FIELDOP1.1529
If(model_flag) then FIELDOP1.1530
FIELDOP1.1531
! Old Format dumpfiles UIE0F404.29
if((lookup(lbnrec,entry_no).eq.0) .or. UIE0F404.30
! Prog lookups in dump before vn3.2: UIE0F404.31
& ((lookup(lbnrec,entry_no).eq.imdi) .and. UIE0F404.32
& (pp_fixhd(12).le.301))) then UIE0F404.33
UIE0F404.34
If(pack_type.eq.2) then ! 32 bit packing. FIELDOP1.1532
FIELDOP1.1533
num_cray_words = (lookup(lblrec,entry_no)+1)/2 FIELDOP1.1534
Else if (pack_type.gt.0) then FIELDOP1.1535
FIELDOP1.1536
num_cray_words = lookup(lblrec,entry_no)/2 FIELDOP1.1537
Else FIELDOP1.1538
FIELDOP1.1539
num_cray_words = lookup(lblrec,entry_no) FIELDOP1.1540
End if FIELDOP1.1541
FIELDOP1.1542
nvals = lookup(lblrec,entry_no) ! No of data points FIELDOP1.1543
addr=data_add1 FIELDOP1.1544
FIELDOP1.1545
If (entry_no.gt.1) then FIELDOP1.1546
FIELDOP1.1547
Do i =1,entry_no-1 FIELDOP1.1548
FIELDOP1.1549
pack_type_i = MOD(lookup(LBPACK,I),10) FIELDOP1.1550
If (pack_type_i .eq. 2) then ! 32 Bit packed FIELDOP1.1551
FIELDOP1.1552
length_of_data = (lookup(lblrec,I)+1)/2 FIELDOP1.1553
Else FIELDOP1.1554
FIELDOP1.1555
length_of_data = lookup(lblrec,I) FIELDOP1.1556
End if FIELDOP1.1557
FIELDOP1.1558
addr = addr + length_of_data FIELDOP1.1559
FIELDOP1.1560
End do ! i FIELDOP1.1561
Else ! If the first entry. FIELDOP1.1562
FIELDOP1.1563
addr = data_add1 FIELDOP1.1564
If (pack_type .eq. 2) then ! 32 Bit packed FIELDOP1.1565
FIELDOP1.1566
length_of_data = (lookup(lblrec,1)+1)/2 FIELDOP1.1567
Else FIELDOP1.1568
FIELDOP1.1569
length_of_data=lookup(lblrec,1) FIELDOP1.1570
End if FIELDOP1.1571
FIELDOP1.1572
write(*,*)' length_of_data ',length_of_data FIELDOP1.1573
FIELDOP1.1574
End if FIELDOP1.1575
FIELDOP1.1576
iwa=addr ! Not -1 as this is already done in dump FIELDOP1.1577
UIE0F404.35
Else UIE0F404.36
! New format Dumpfiles (vn4.4 onwards) UIE0F404.37
UIE0F404.38
If(pack_type.eq.2) then ! 32 bit packing. UIE0F404.39
num_cray_words=(lookup(lblrec,entry_no)+1)/2 UIE0F404.40
Elseif(pack_type.gt.0) then UIE0F404.41
num_cray_words=lookup(lblrec,entry_no)/2 UIE0F404.42
Else UIE0F404.43
num_cray_words=lookup(lblrec,entry_no) UIE0F404.44
Endif UIE0F404.45
iwa = lookup(LBEGIN,entry_no) UIE0F404.46
nvals = lookup(lbrow,entry_no) * lookup(lbnpt,entry_no) UIE0F404.47
Endif UIE0F404.48
Else ! Reading a PP type file. FIELDOP1.1578
FIELDOP1.1579
num_cray_words = lookup(lblrec,entry_no) ! PP type file FIELDOP1.1580
iwa = lookup(LBEGIN,entry_no) FIELDOP1.1581
nvals = lookup(lbrow,entry_no) * lookup(lbnpt,entry_no) FIELDOP1.1582
& + lookup(lbext,entry_no) FIELDOP1.1583
FIELDOP1.1584
End if FIELDOP1.1585
FIELDOP1.1586
107 FORMAT(' ENTRY NO=',I5,'num_cray_words= ',I6,'nvals=',I6) FIELDOP1.1587
FIELDOP1.1588
If (idim .lt. num_cray_words) then FIELDOP1.1589
FIELDOP1.1590
icode = num_cray_words FIELDOP1.1591
cmessage ='readff Idim to small icode holds correct value' FIELDOP1.1592
goto 9999 FIELDOP1.1593
FIELDOP1.1594
End if FIELDOP1.1595
FIELDOP1.1596
icode=0 FIELDOP1.1597
call read_rec(field, ! OUT array holding data FIELDOP1.1598
& num_cray_words, ! IN No of CRAY words holding data FIELDOP1.1599
& iwa, ! IN WORD address of field to be read FIELDOP1.1600
& pp_unit1, ! IN unit no of the file FIELDOP1.1601
& max_len, FIELDOP1.1602
& icode) ! IN/OUT FIELDOP1.1603
FIELDOP1.1604
2212 FORMAT(' FIELDS FILE NUMBER ',I2,' ON UNIT',I2,2X,'BEING read') FIELDOP1.1605
FIELDOP1.1606
If (icode.eq.0) then FIELDOP1.1607
FIELDOP1.1608
pos_rlabel = MOD(lookup(lbrel,entry_no),100) FIELDOP1.1609
FIELDOP1.1610
! Treat lookup(45) (submodel identifier) as an integer. UIE0F402.4
POS_RLABEL=46 UIE0F402.5
FIELDOP1.1618
FIELDOP1.1619
len_rlabel=1+len1_lookup-pos_rlabel FIELDOP1.1620
len_ilabel=len1_lookup-len_rlabel FIELDOP1.1621
FIELDOP1.1622
Do i=1,len_ilabel FIELDOP1.1623
ilabel(i)=lookup(i,entry_no) FIELDOP1.1624
End do FIELDOP1.1625
FIELDOP1.1626
C check for valid release number FIELDOP1.1627
if (ilabel(lbrel).lt.1) then FIELDOP1.1628
FIELDOP1.1629
write(*,*)' resetting LBREL from',ilabel(lbrel),' to 2' FIELDOP1.1630
ilabel(lbrel)=2 FIELDOP1.1631
FIELDOP1.1632
endif FIELDOP1.1633
FIELDOP1.1634
Do i=1,len_rlabel FIELDOP1.1635
rlabel(i)=rookup(i+pos_rlabel-1,entry_no) FIELDOP1.1636
End do FIELDOP1.1637
FIELDOP1.1638
End if FIELDOP1.1639
FIELDOP1.1640
! At this point field holds the data either packed or un-packed FIELDOP1.1641
! Is the packing indicator set and is un-packing required? FIELDOP1.1642
! If so then the data is temp un-packed into a work array of FIELDOP1.1643
! length idim FIELDOP1.1644
If (pack_type.gt.0) then ! Is the field packed. FIELDOP1.1645
FIELDOP1.1646
call un_pack(pack_type, ! IN packing type N1 of LBPACK FIELDOP1.1647
& idim, ! IN length of unpacked pp buffer FIELDOP1.1648
& field, ! IN/OUT I/P contains packed data FIELDOP1.1649
& ! Output contains un-packed data. FIELDOP1.1650
& num_cray_words, ! IN length of input field FIELDOP1.1651
& ilabel, ! IN holds integer part of lookup FIELDOP1.1652
& len_ilabel, ! IN length of ilabel array FIELDOP1.1653
& amdi, ! IN Missing data indicator. FIELDOP1.1654
& pp_fixhd, ! IN PPfile fixed length header FIELDOP1.1655
& len_fixhd, FIELDOP1.1656
& pppak, UIE0F403.313
& icode,cmessage) ! IN/OUT FIELDOP1.1658
FIELDOP1.1659
Else if(lookup(data_type,entry_no).eq.2) then !Fld is integer FIELDOP1.1660
FIELDOP1.1661
call integer_to_real(idim, ! IN full unpacked size of field FIELDOP1.1662
& field, ! IN contains integer data. FIELDOP1.1663
& field, ! OUT contains Real data. FIELDOP1.1664
& nvals, ! IN no of values in field FIELDOP1.1665
& max_len, FIELDOP1.1666
& ilabel, ! IN/OUT integer part of lookup FIELDOP1.1667
& icode) ! IN/OUT error code FIELDOP1.1668
FIELDOP1.1669
End if FIELDOP1.1670
FIELDOP1.1671
9999 continue FIELDOP1.1672
100 FORMAT(//,32X,' ARRAY ',//,32(16F5.0/)) FIELDOP1.1673
101 FORMAT(//,32X,' lookup ',//,32(16I5/)) FIELDOP1.1674
103 FORMAT(' LENIN ',I12) FIELDOP1.1675
FIELDOP1.1676
RETURN FIELDOP1.1677
END FIELDOP1.1678
FIELDOP1.1679
! FIELDOP1.1680
! Subroutine interface: FIELDOP1.1681
subroutine read_rec(field, 3,6FIELDOP1.1682
& num_cray_words, FIELDOP1.1683
& iwa, FIELDOP1.1684
& pp_unit1, FIELDOP1.1685
& max_len, FIELDOP1.1686
& icode) FIELDOP1.1687
FIELDOP1.1688
IMPLICIT NONE FIELDOP1.1689
! FIELDOP1.1690
! FIELDOP1.1691
! Description: To read a data record from a pp file/dump. FIELDOP1.1692
! FIELDOP1.1693
! Method: FIELDOP1.1694
! FIELDOP1.1695
! Current Code Owner: I Edmond FIELDOP1.1696
! FIELDOP1.1697
! History: FIELDOP1.1698
! Version Date Comment FIELDOP1.1699
! ------- ---- ------- FIELDOP1.1700
! <version> <date> Original code. <Your name> FIELDOP1.1701
! FIELDOP1.1702
! Code Description: FIELDOP1.1703
! Language: FORTRAN 77 + common extensions. FIELDOP1.1704
! This code is written to UMDP3 v6 programming standards. FIELDOP1.1705
! FIELDOP1.1706
! System component covered: <appropriate code> FIELDOP1.1707
! System Task: <appropriate code> FIELDOP1.1708
! FIELDOP1.1709
! Declarations: FIELDOP1.1710
! These are of the form:- FIELDOP1.1711
! INTEGER ExampleVariable !Description of variable FIELDOP1.1712
! FIELDOP1.1713
! Subroutine arguments FIELDOP1.1714
! Scalar arguments with intent(in): FIELDOP1.1715
INTEGER FIELDOP1.1716
& num_cray_words, !IN No of CRAY words holding the data FIELDOP1.1717
& max_len, FIELDOP1.1718
& pp_unit1, !IN unit no of the PP FILE FIELDOP1.1719
& iwa !IN WORD address of field to be read FIELDOP1.1720
FIELDOP1.1721
! Scalar arguments with intent(out): FIELDOP1.1722
INTEGER FIELDOP1.1723
& icode !OUT error code FIELDOP1.1724
FIELDOP1.1725
! Array arguments with intent(out): FIELDOP1.1726
REAL FIELDOP1.1727
& field(max_len) !OUT array holding data FIELDOP1.1728
FIELDOP1.1729
! Local scalars. FIELDOP1.1730
INTEGER FIELDOP1.1731
& i,j, ! local counter FIELDOP1.1732
& len_io ! length of data read by buffin FIELDOP1.1733
FIELDOP1.1734
REAL FIELDOP1.1735
& a_io ! return code from buffin FIELDOP1.1736
FIELDOP1.1737
! Function & Subroutine calls: FIELDOP1.1738
External setpos,buffin FIELDOP1.1739
FIELDOP1.1740
!- End of header FIELDOP1.1741
FIELDOP1.1742
call setpos(pp_unit1,iwa,icode) FIELDOP1.1743
call buffin(pp_unit1,field,num_cray_words,len_io,a_io) FIELDOP1.1744
FIELDOP1.1745
RETURN FIELDOP1.1746
END FIELDOP1.1747
! FIELDOP1.1748
! Subroutine interface: FIELDOP1.1749
subroutine un_pack(pack_type, 4,10FIELDOP1.1750
& npoints, UIE0F403.447
& pdata, UIE0F403.448
& num_cray_words, FIELDOP1.1753
& ilabel, FIELDOP1.1754
& len_ilabel, FIELDOP1.1755
& amdi, FIELDOP1.1756
& pp_fixhd, FIELDOP1.1757
& len_fixhd, FIELDOP1.1758
& pppak, UIE0F403.449
& icode,cmessage) FIELDOP1.1760
IMPLICIT NONE FIELDOP1.1761
! FIELDOP1.1762
! Description: To unpack data from the input array pdata and return UIE0F403.450
! the data in pdata. UIE0F403.451
! FIELDOP1.1765
! Method: FIELDOP1.1766
! FIELDOP1.1767
! Current Code Owner: I Edmond FIELDOP1.1768
! FIELDOP1.1769
! History: FIELDOP1.1770
! Version Date Comment FIELDOP1.1771
! ------- ---- ------- FIELDOP1.1772
! <version> <date> Original code. <Your name> FIELDOP1.1773
! FIELDOP1.1774
! Code Description: FIELDOP1.1775
! Language: FORTRAN 77 + common extensions. FIELDOP1.1776
! This code is written to UMDP3 v6 programming standards. FIELDOP1.1777
! FIELDOP1.1778
! System component covered: <appropriate code> FIELDOP1.1779
! System Task: <appropriate code> FIELDOP1.1780
! FIELDOP1.1781
! Declarations: FIELDOP1.1782
! These are of the form:- FIELDOP1.1783
! INTEGER ExampleVariable !Description of variable FIELDOP1.1784
! FIELDOP1.1785
! 1.0 Global variables (*CALLed COMDECKs etc...): FIELDOP1.1786
*CALL CLOOKADD FIELDOP1.1787
FIELDOP1.1788
! Subroutine arguments FIELDOP1.1789
! Scalar arguments with intent(in): FIELDOP1.1790
INTEGER FIELDOP1.1791
& npoints, ! full unpacked size of a pdata UIE0F403.452
& max_len, FIELDOP1.1793
& num_cray_words, ! length of input pdata UIE0F403.453
& len_fixhd, FIELDOP1.1795
& len_ilabel ! length of ilabel array FIELDOP1.1796
FIELDOP1.1797
REAL FIELDOP1.1798
& amdi ! Missing data indicator. FIELDOP1.1799
FIELDOP1.1800
! Scalar arguments with intent(in): FIELDOP1.1801
INTEGER FIELDOP1.1802
& pp_fixhd(len_fixhd) ! PPfile fixed length header FIELDOP1.1803
FIELDOP1.1804
! Scalar arguments with intent(in/out): FIELDOP1.1805
INTEGER FIELDOP1.1806
& pack_type ! Type of packing used FIELDOP1.1807
FIELDOP1.1808
! Array arguments with intent(in/out): FIELDOP1.1809
INTEGER FIELDOP1.1810
& ilabel(len_ilabel) FIELDOP1.1811
FIELDOP1.1812
FIELDOP1.1816
! ErrorStatus FIELDOP1.1817
INTEGER FIELDOP1.1818
& icode FIELDOP1.1819
FIELDOP1.1820
CHARACTER FIELDOP1.1821
& cmessage*80 FIELDOP1.1822
FIELDOP1.1823
! Local scalars: FIELDOP1.1824
INTEGER FIELDOP1.1825
& num_unpack_values, ! Number of numbers originally packed FIELDOP1.1826
& i, ! loop counter FIELDOP1.1827
& ixx, ! Returned X dimension from COEX FIELDOP1.1828
& iyy, ! Returned Y dimension from COEX FIELDOP1.1829
& idum, ! Dummy variable UIE0F403.454
& pppak ! Packing acc UIE0F403.455
FIELDOP1.1831
! Local parameters: FIELDOP1.1832
INTEGER len_full_word ! The length of a FULL_WORD FIELDOP1.1833
PARAMETER(len_full_word=64) FIELDOP1.1834
FIELDOP1.1835
! Local arrays: FIELDOP1.1836
REAL FIELDOP1.1837
& field(npoints) !WORK array used for un_packing UIE0F403.456
&,pdata(npoints) ! Input contains packed data. UIE0F403.457
FIELDOP1.1839
! Function & Subroutine calls: FIELDOP1.1840
External coex,degrib,EXPAND21,P21BITS FIELDOP1.1841
INTEGER P21BITS FIELDOP1.1842
FIELDOP1.1843
!- End of header FIELDOP1.1844
FIELDOP1.1845
If (pack_type.eq.1) then ! WGDOS packing FIELDOP1.1846
FIELDOP1.1847
call coex(field, ! OUT UIE0F403.458
& npoints, ! IN UIE0F403.459
& pdata, ! IN UIE0F403.460
& npoints, ! IN UIE0F403.461
& ixx,iyy, ! OUT FIELDOP1.1852
& idum, UIE0F403.462
& pppak, ! OUT UIE0F403.463
& .false., ! IN FIELDOP1.1854
& amdi, ! IN FIELDOP1.1855
& len_full_word) ! IN FIELDOP1.1856
FIELDOP1.1857
num_unpack_values = ixx * iyy FIELDOP1.1858
ilabel(lblrec) = ilabel(lbrow) * ilabel(lbnpt) + ilabel(lbext) FIELDOP1.1859
Else if (pack_type .eq. 2) then ! 32 Bit CRAY packing FIELDOP1.1860
FIELDOP1.1861
UIE0F403.464
num_cray_words = num_cray_words*2 UIE0F403.465
call EXPAND21(num_cray_words, ! IN UIE0F403.466
& pdata, ! IN UIE0F403.467
& field, ! OUT UIE0F403.468
& P21BITS(pp_fixhd(12))) ! IN UIE0F403.469
UIE0F403.470
num_unpack_values = num_cray_words UIE0F403.471
UIE0F403.472
FIELDOP1.1867
Else if (pack_type .eq. 3) then ! GRIB packing FIELDOP1.1869
FIELDOP1.1870
call degrib(pdata, ! IN UIE0F403.473
& field, ! OUT UIE0F403.474
& npoints, ! IN UIE0F403.475
& num_cray_words, ! IN FIELDOP1.1874
& ilabel, ! IN FIELDOP1.1875
& amdi, ! IN FIELDOP1.1876
& num_unpack_values, ! IN FIELDOP1.1877
& len_full_word) ! IN FIELDOP1.1878
Else FIELDOP1.1879
FIELDOP1.1880
icode=6 FIELDOP1.1881
cmessage=' UNPACK - packing type not yet supported' FIELDOP1.1882
End if FIELDOP1.1883
FIELDOP1.1884
! Write unpacked data back into array pdata. UIE0F403.476
Do i =1,num_unpack_values FIELDOP1.1886
pdata(i) = field(i) UIE0F403.477
End do FIELDOP1.1888
FIELDOP1.1889
ilabel(data_type) =1 ! data must now be real FIELDOP1.1890
ilabel(LBPACK) =ilabel(LBPACK)-pack_type ! data no FIELDOP1.1891
pack_type =0 ! longer packed FIELDOP1.1892
FIELDOP1.1893
RETURN FIELDOP1.1894
END FIELDOP1.1895
! FIELDOP1.1896
!Subroutine interface: FIELDOP1.1897
subroutine integer_to_real(idim,integer_field,field,nvals, 3FIELDOP1.1898
& max_len,ilabel,icode) FIELDOP1.1899
IMPLICIT NONE FIELDOP1.1900
! FIELDOP1.1901
! Description: Converts integer data into real. FIELDOP1.1902
! FIELDOP1.1903
! Method: FIELDOP1.1904
! FIELDOP1.1905
! Current Code Owner: I Edmond FIELDOP1.1906
! FIELDOP1.1907
! History: FIELDOP1.1908
! Version Date Comment FIELDOP1.1909
! ------- ---- ------- FIELDOP1.1910
! <version> <date> Original code. <Your name> FIELDOP1.1911
! FIELDOP1.1912
! Code Description: FIELDOP1.1913
! Language: FORTRAN 77 + common extensions. FIELDOP1.1914
! This code is written to UMDP3 v6 programming standards. FIELDOP1.1915
! FIELDOP1.1916
! System component covered: <appropriate code> FIELDOP1.1917
! System Task: <appropriate code> FIELDOP1.1918
! FIELDOP1.1919
! Declarations: FIELDOP1.1920
! These are of the form:- FIELDOP1.1921
! INTEGER ExampleVariable !Description of variable FIELDOP1.1922
! FIELDOP1.1923
! 1.0 Global variables (*CALLed COMDECKs etc...): FIELDOP1.1924
*CALL CLOOKADD FIELDOP1.1925
FIELDOP1.1926
! Subroutine arguments FIELDOP1.1927
! Scalar arguments with intent(in): FIELDOP1.1928
INTEGER FIELDOP1.1929
& idim, !IN full unpacked size of a field FIELDOP1.1930
& max_len, FIELDOP1.1931
& nvals !IN no of values in an input field FIELDOP1.1932
FIELDOP1.1933
! Array arguments with intent(in): FIELDOP1.1934
INTEGER FIELDOP1.1935
& integer_field(max_len) ! contains integer data. FIELDOP1.1936
FIELDOP1.1937
! Scalar arguments with intent(out): FIELDOP1.1938
INTEGER FIELDOP1.1939
& icode !OUT error code FIELDOP1.1940
FIELDOP1.1941
! Array arguments with intent(out): FIELDOP1.1942
INTEGER FIELDOP1.1943
& ilabel(44) !OUT integer part of lookup FIELDOP1.1944
FIELDOP1.1945
REAL FIELDOP1.1946
& field(max_len) !OUT contains Real data. FIELDOP1.1947
FIELDOP1.1948
! Local scalars: FIELDOP1.1949
INTEGER FIELDOP1.1950
& i ! loop counter FIELDOP1.1951
FIELDOP1.1952
!- End of header FIELDOP1.1953
FIELDOP1.1954
Do i =1,nvals FIELDOP1.1955
field(i) = integer_field(i) FIELDOP1.1956
End do FIELDOP1.1957
FIELDOP1.1958
ilabel(data_type) =1 ! The data type must now be real FIELDOP1.1959
icode=0 FIELDOP1.1960
FIELDOP1.1961
RETURN FIELDOP1.1962
END FIELDOP1.1963
! UIE0F403.171
!Subroutine interface: UIE0F403.172
SUBROUTINE PP_FILE(PPFIELD,LENBUF,NUM_WORDS,RMDI,COMP_ACCRCY, 5,10UIE0F403.173
&PPHORIZ_OUT,UNITPP,DATA_ADD,N_COLS_OUT,N_ROWS_OUT,PACKING, UIE0F403.174
&PACKING_TYPE,LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP,ENTRY_NO, UIE0F403.175
&ICODE,CMESSAGE) UIE0F403.176
IMPLICIT NONE UIE0F403.177
! UIE0F403.178
! Description: To output a field to a PP_FILE UIE0F403.179
! UIE0F403.180
! Method: UIE0F403.181
! UIE0F403.182
! Current Code Owner: I Edmond UIE0F403.183
! UIE0F403.184
! History: UIE0F403.185
! Version Date Comment UIE0F403.186
! ------- ---- ------- UIE0F403.187
! <version> <date> Original code. <Your name> UIE0F403.188
! UIE0F403.189
! Code Description: UIE0F403.190
! Language: FORTRAN 77 + common extensions. UIE0F403.191
! This code is written to UMDP3 v6 programming standards. UIE0F403.192
! UIE0F403.193
! System component covered: <appropriate code> UIE0F403.194
! System Task: <appropriate code> UIE0F403.195
! UIE0F403.196
! Declarations: UIE0F403.197
! These are of the form:- UIE0F403.198
! INTEGER ExampleVariable !Description of variable UIE0F403.199
! UIE0F403.200
! Subroutine arguments UIE0F403.201
! Scalar arguments with intent(in): UIE0F403.202
INTEGER UIE0F403.203
& ICODE ! RETURN CODE FROM ROUTINE UIE0F403.204
&, LENBUF ! LENGTH OFF PP BUFFER UIE0F403.205
&, UNITPP ! OUTPUT PP UNIT NUMBER UIE0F403.206
&, LEN_IO !NOT USED, BUT NEEDED FOR BUFFOUT CALL UIE0F403.207
UIE0F403.208
INTEGER UIE0F403.209
& N_ROWS_OUT ! PPHORIZ_OUT=N_ROWS_OUT*N_COLS_OUT UIE0F403.210
&, N_COLS_OUT ! PPHORIZ_OUT=N_COLS_OUT*N_ROWS_OUT UIE0F403.211
&, NUM_OUT ! NUMBER OF COMPRESSED (32 BIT) WORDS UIE0F403.212
&, DATA_ADD ! UIE0F403.213
&, ENTRY_NO ! UIE0F403.214
&, COMP_ACCRCY ! PACKING ACCURACY IN POWER OF 2 UIE0F403.215
&, PPHORIZ_OUT ! SIZE OF OUTPUT FIELD UIE0F403.216
&, NUM_WORDS ! NUMBER OF 64 BIT WORDS WORTH OF DATA UIE0F403.217
&, PACKING_TYPE UIE0F403.218
&, LEN1_LOOKUP UIE0F403.219
&, LEN2_LOOKUP UIE0F403.220
UIE0F403.221
REAL UIE0F403.222
& RMDI !IN Missing data indicator UIE0F403.223
UIE0F403.224
LOGICAL UIE0F403.225
& PACKING !IN OVERALL Packing switch (T if pckng reqd) UIE0F403.226
UIE0F403.227
! Array arguments with intent(in): UIE0F403.228
INTEGER UIE0F403.229
& LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) UIE0F403.230
UIE0F403.231
REAL UIE0F403.232
& PPFIELD(PPHORIZ_OUT) !INOUT ARRAY TO STORE PPDATA UIE0F403.233
UIE0F403.234
! Scalar arguments with intent(out): UIE0F403.235
CHARACTER*(80) CMESSAGE !OUT OUT MESSAGE FROM ROUTINE UIE0F403.236
UIE0F403.237
! Array arguments with intent(out): UIE0F403.238
REAL UIE0F403.239
& BUFOUT(LENBUF) !OUTPUT PP BUFFER (ROUNDED UP) UIE0F403.240
UIE0F403.241
*CALL CNTL_IO UDG1F405.1567
! Local scalars: UIE0F403.242
INTEGER UIE0F403.243
& LENGTH_FULLWRD! LENGTH IN BITS OF FULLWORD VAR UIE0F403.244
&,LEN_BUF_WORDS ! NUM_WORDS ROUNDED BY 512 UIE0F403.245
&,POS UIE0F403.246
UIE0F403.247
INTEGER UIE0F403.248
& JJ ! Local counter UIE0F403.249
UIE0F403.250
REAL UIE0F403.251
& IX ! RETURN VALUE FROM UNIT COMMAND UIE0F403.252
! Function & Subroutine calls: UIE0F403.253
External SETPOS,COEX,BUFFOUT UIE0F403.254
UIE0F403.255
!- End of header UIE0F403.256
UIE0F403.257
UIE0F403.258
LENGTH_FULLWRD=64 ! LENGTH IN BITS OF FULLWORD VAR UIE0F403.259
! At this point packing,if required,will be done using the WGDOS UIE0F403.260
! method of packing. UIE0F403.261
PACKING_TYPE=0 UIE0F403.262
UIE0F403.263
IF(PACKING.AND.COMP_ACCRCY.GT.-99.AND.N_COLS_OUT.GE.2) UIE0F403.264
& PACKING_TYPE=1 UIE0F403.265
UIE0F403.266
IF(PACKING_TYPE.EQ.1)THEN UIE0F403.267
UIE0F403.268
CALL COEX(PPFIELD,PPHORIZ_OUT,BUFOUT,LENBUF,N_COLS_OUT, UIE0F403.269
& N_ROWS_OUT,NUM_OUT,COMP_ACCRCY,.TRUE.,RMDI,LENGTH_FULLWRD) UIE0F403.270
UIE0F403.271
NUM_WORDS=(NUM_OUT+1)/2 ! Round up to the nearest 64 Bit CRAY Wd UIE0F403.272
LEN_BUF_WORDS=((NUM_WORDS+UM_SECTOR_SIZE-1)/UM_SECTOR_SIZE)* UDG1F405.1568
! UM_SECTOR_SIZE UDG1F405.1569
UIE0F403.274
ELSE ! No packing required. UIE0F403.275
UIE0F403.276
DO JJ=1,PPHORIZ_OUT UIE0F403.277
BUFOUT(JJ) = PPFIELD(JJ) UIE0F403.278
END DO UIE0F403.279
UIE0F403.280
NUM_WORDS=PPHORIZ_OUT UIE0F403.281
LEN_BUF_WORDS=((NUM_WORDS+UM_SECTOR_SIZE-1)/UM_SECTOR_SIZE)* UDG1F405.1570
! UM_SECTOR_SIZE UDG1F405.1571
UIE0F403.283
ENDIF UIE0F403.284
UIE0F403.285
! Update lookup header data lengths and addressing for UIE0F403.286
! wgdos packed data in fieldsfile. UIE0F403.287
LOOKUP(15,ENTRY_NO) = NUM_WORDS UIE0F403.288
LOOKUP(30,ENTRY_NO) = LEN_BUF_WORDS UIE0F403.289
IF (ENTRY_NO .eq. 1) THEN UIE0F403.290
LOOKUP(29,ENTRY_NO) = DATA_ADD UIE0F403.291
ELSE UIE0F403.292
LOOKUP(29,ENTRY_NO) = LOOKUP(29,ENTRY_NO-1) UIE0F403.293
& + LOOKUP(30,ENTRY_NO-1) UIE0F403.294
ENDIF UIE0F403.295
LOOKUP(40,ENTRY_NO) = LOOKUP(29,ENTRY_NO) UIE0F403.296
! Set position in output file to buffer out lookup header info. UIE0F403.297
POS = LOOKUP(40,ENTRY_NO) UIE0F403.298
UIE0F403.299
DO JJ=NUM_WORDS+1,LEN_BUF_WORDS UIE0F403.300
BUFOUT(JJ)= 0.0 UIE0F403.301
ENDDO UIE0F403.302
UIE0F403.303
CALL SETPOS(UNITPP,POS,ICODE) UIE0F403.304
CALL BUFFOUT(UNITPP,BUFOUT(1),LEN_BUF_WORDS,LEN_IO,IX) UIE0F403.305
UIE0F403.306
RETURN UIE0F403.307
END UIE0F403.308
*ENDIF FIELDOP1.1964