PROGRAM MAIN_COMPARE ,20COMPARE1.37
COMPARE1.38
IMPLICIT NONE COMPARE1.39
COMPARE1.40
INTEGER COMPARE1.41
& FIXHD1(256) !Space for fixed length header file 1 COMPARE1.42
&,INTHD1(100) !Space for integer header file 1 COMPARE1.43
COMPARE1.44
INTEGER COMPARE1.45
& FIXHD2(256) !Space for fixed length header file 2 COMPARE1.46
&,INTHD2(100) !Space for integer header file 2 COMPARE1.47
COMPARE1.48
INTEGER COMPARE1.49
& LEN_FIXHD1 !Length of fixed length header on file 1 COMPARE1.50
&,LEN_INTHD1 !Length of integer header on file 1 COMPARE1.51
&,LEN_REALHD1 !Length of real header on file 1 COMPARE1.52
&,LEN1_LEVDEPC1 !1st dim of lev dependent consts on file 1 COMPARE1.53
&,LEN2_LEVDEPC1 !2nd dim of lev dependent consts on file 1 COMPARE1.54
&,LEN1_ROWDEPC1 !1st dim of row dependent consts on file 1 COMPARE1.55
&,LEN2_ROWDEPC1 !2nd dim of row dependent consts on file 1 COMPARE1.56
&,LEN1_COLDEPC1 !1st dim of col dependent consts on file 1 COMPARE1.57
&,LEN2_COLDEPC1 !2nd dim of col dependent consts on file 1 COMPARE1.58
&,LEN1_FLDDEPC1 !1st dim of field dependent consts on file 1 COMPARE1.59
&,LEN2_FLDDEPC1 !2nd dim of field dependent consts on file 1 COMPARE1.60
&,LEN_EXTCNST1 !Length of extra consts on file 1 COMPARE1.61
&,LEN_DUMPHIST1 !Length of history header on file 1 COMPARE1.62
&,LEN_CFI11 !Length of index1 on file 1 COMPARE1.63
&,LEN_CFI21 !Length of index2 on file 1 COMPARE1.64
&,LEN_CFI31 !Length of index3 on file 1 COMPARE1.65
&,LEN1_LOOKUP1 !1st dim of LOOKUP on file 1 COMPARE1.66
&,LEN2_LOOKUP1 !2nd dim of LOOKUP on file 1 COMPARE1.67
&,LEN_DATA1 !Length of data on file 1 COMPARE1.68
&,ROW_LENGTH1 !No of points E-W on file 1 COMPARE1.69
&,P_ROWS1 !No of p-rows on file 1 COMPARE1.70
&,P_FIELD1 !No of p-points per level on file 1 COMPARE1.71
&,MAX_FIELD_SIZE1 !Maximum field size on file 1 AD311093.33
COMPARE1.72
INTEGER COMPARE1.73
& LEN_FIXHD2 !Length of fixed length header on file 2 COMPARE1.74
&,LEN_INTHD2 !Length of integer header on file 2 COMPARE1.75
&,LEN_REALHD2 !Length of real header on file 2 COMPARE1.76
&,LEN1_LEVDEPC2 !1st dim of lev dependent consts on file 2 COMPARE1.77
&,LEN2_LEVDEPC2 !2nd dim of lev dependent consts on file 2 COMPARE1.78
&,LEN1_ROWDEPC2 !1st dim of row dependent consts on file 2 COMPARE1.79
&,LEN2_ROWDEPC2 !2nd dim of row dependent consts on file 2 COMPARE1.80
&,LEN1_COLDEPC2 !1st dim of col dependent consts on file 2 COMPARE1.81
&,LEN2_COLDEPC2 !2nd dim of col dependent consts on file 2 COMPARE1.82
&,LEN1_FLDDEPC2 !1st dim of field dependent consts on file 2 COMPARE1.83
&,LEN2_FLDDEPC2 !2nd dim of field dependent consts on file 2 COMPARE1.84
&,LEN_EXTCNST2 !Length of extra consts on file 2 COMPARE1.85
&,LEN_DUMPHIST2 !Length of history header on file 2 COMPARE1.86
&,LEN_CFI12 !Length of index1 on file 2 COMPARE1.87
&,LEN_CFI22 !Length of index2 on file 2 COMPARE1.88
&,LEN_CFI32 !Length of index3 on file 2 COMPARE1.89
&,LEN1_LOOKUP2 !1st dim of LOOKUP on file 2 COMPARE1.90
&,LEN2_LOOKUP2 !2nd dim of LOOKUP on file 2 COMPARE1.91
&,LEN_DATA2 !Length of data on file 2 COMPARE1.92
&,ROW_LENGTH2 !No of points E-W on file 2 COMPARE1.93
&,P_ROWS2 !No of p-rows on file 2 COMPARE1.94
&,P_FIELD2 !No of p-points per level on file 2 COMPARE1.95
&,MAX_FIELD_SIZE2 !Maximum field size on file 2 AD311093.34
COMPARE1.96
COMPARE1.97
INTEGER COMPARE1.98
& LEN_IO !Length of I/O returned by BUFFER IN COMPARE1.99
&,I !Loop index COMPARE1.100
&,NFTIN1 !Unit number of input UM file 1 COMPARE1.101
&,NFTIN2 !Unit number of input UM file 2 COMPARE1.102
COMPARE1.103
&,ERR !Return code from OPEN COMPARE1.104
&,ICODE !Return code from setpos GTD0F400.44
REAL A !BUFFER IN UNIT function COMPARE1.105
c UBC3F402.1
integer wgdos_expand UBC3F402.2
COMPARE1.106
COMPARE1.107
C External subroutines called:------------------------------------------ COMPARE1.108
EXTERNAL IOERROR,ABORT_IO,BUFFIN,FILE_OPEN, GPB1F305.12
& SETPOS,ABORT,COMPARE GPB1F305.13
C*---------------------------------------------------------------------- COMPARE1.110
COMPARE1.111
c UBC3F402.3
wgdos_expand=1 UBC3F402.4
CL 1. Assign unit numbers COMPARE1.112
COMPARE1.113
NFTIN1=20 COMPARE1.114
NFTIN2=21 COMPARE1.115
COMPARE1.116
WRITE(6,*)' COMPARE - FULL MODE' COMPARE1.117
WRITE(6,*)' -------------------' COMPARE1.118
WRITE(6,*)' ' COMPARE1.119
COMPARE1.120
WRITE(6,'(20x,''FILE STATUS'')') COMPARE1.121
WRITE(6,'(20x,''==========='')') COMPARE1.122
C CALL OPEN(1,'PPXREF',6,0,0,ERR) COMPARE1.123
CALL FILE_OPEN
(NFTIN1,'FILE1',5,0,0,ERR) GPB1F305.14
CALL FILE_OPEN(NFTIN2,'FILE2',5,0,0,ERR) GPB1F305.15
COMPARE1.126
CL 2. Buffer in fixed length header record from file 1 COMPARE1.127
COMPARE1.128
CALL BUFFIN(NFTIN1,FIXHD1,256,LEN_IO,A) COMPARE1.129
COMPARE1.130
C Check for I/O errors COMPARE1.131
IF(A.NE.-1.0.OR.LEN_IO.NE.256)THEN COMPARE1.132
CALL IOERROR('buffer in of fixed length header of input file', COMPARE1.133
* A,LEN_IO,256) COMPARE1.134
CALL ABORT COMPARE1.135
ENDIF COMPARE1.136
COMPARE1.137
C Set missing data indicator to zero COMPARE1.138
DO I=1,256 COMPARE1.139
IF(FIXHD1(I).LT.0)FIXHD1(I)=0 COMPARE1.140
ENDDO COMPARE1.141
COMPARE1.142
C Input file dimensions COMPARE1.143
LEN_FIXHD1=256 COMPARE1.144
LEN_INTHD1=FIXHD1(101) COMPARE1.145
LEN_REALHD1=FIXHD1(106) COMPARE1.146
LEN1_LEVDEPC1=FIXHD1(111) COMPARE1.147
LEN2_LEVDEPC1=FIXHD1(112) COMPARE1.148
LEN1_ROWDEPC1=FIXHD1(116) COMPARE1.149
LEN2_ROWDEPC1=FIXHD1(117) COMPARE1.150
LEN1_COLDEPC1=FIXHD1(121) COMPARE1.151
LEN2_COLDEPC1=FIXHD1(122) COMPARE1.152
LEN1_FLDDEPC1=FIXHD1(126) COMPARE1.153
LEN2_FLDDEPC1=FIXHD1(127) COMPARE1.154
LEN_EXTCNST1=FIXHD1(131) COMPARE1.155
LEN_DUMPHIST1=FIXHD1(136) COMPARE1.156
LEN_CFI11=FIXHD1(141) COMPARE1.157
LEN_CFI21=FIXHD1(143) COMPARE1.158
LEN_CFI31=FIXHD1(145) COMPARE1.159
LEN1_LOOKUP1=FIXHD1(151) COMPARE1.160
LEN2_LOOKUP1=FIXHD1(152) COMPARE1.161
LEN_DATA1=FIXHD1(161) COMPARE1.162
COMPARE1.163
CL 3. Buffer in fixed length header record from file 2 COMPARE1.164
COMPARE1.165
CALL BUFFIN(NFTIN2,FIXHD2,256,LEN_IO,A) COMPARE1.166
COMPARE1.167
C Check for I/O errors COMPARE1.168
IF(A.NE.-1.0.OR.LEN_IO.NE.256)THEN COMPARE1.169
CALL IOERROR('buffer in of fixed length header of input file', COMPARE1.170
* A,LEN_IO,256) COMPARE1.171
CALL ABORT COMPARE1.172
ENDIF COMPARE1.173
COMPARE1.174
C Set missing data indicator to zero COMPARE1.175
DO I=1,256 COMPARE1.176
IF(FIXHD2(I).LT.0)FIXHD2(I)=0 COMPARE1.177
ENDDO COMPARE1.178
COMPARE1.179
C Input file dimensions COMPARE1.180
LEN_FIXHD2=256 COMPARE1.181
LEN_INTHD2=FIXHD2(101) COMPARE1.182
LEN_REALHD2=FIXHD2(106) COMPARE1.183
LEN1_LEVDEPC2=FIXHD2(111) COMPARE1.184
LEN2_LEVDEPC2=FIXHD2(112) COMPARE1.185
LEN1_ROWDEPC2=FIXHD2(116) COMPARE1.186
LEN2_ROWDEPC2=FIXHD2(117) COMPARE1.187
LEN1_COLDEPC2=FIXHD2(121) COMPARE1.188
LEN2_COLDEPC2=FIXHD2(122) COMPARE1.189
LEN1_FLDDEPC2=FIXHD2(126) COMPARE1.190
LEN2_FLDDEPC2=FIXHD2(127) COMPARE1.191
LEN_EXTCNST2=FIXHD2(131) COMPARE1.192
LEN_DUMPHIST2=FIXHD2(136) COMPARE1.193
LEN_CFI12=FIXHD2(141) COMPARE1.194
LEN_CFI22=FIXHD2(143) COMPARE1.195
LEN_CFI32=FIXHD2(145) COMPARE1.196
LEN1_LOOKUP2=FIXHD2(151) COMPARE1.197
LEN2_LOOKUP2=FIXHD2(152) COMPARE1.198
LEN_DATA2=FIXHD2(161) COMPARE1.199
COMPARE1.200
COMPARE1.201
CL 4. Buffer in integer constants from file 1 COMPARE1.202
COMPARE1.203
CALL BUFFIN(NFTIN1,INTHD1,FIXHD1(101),LEN_IO,A) COMPARE1.204
COMPARE1.205
C Check for I/O errors COMPARE1.206
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD1(101))THEN COMPARE1.207
CALL IOERROR('buffer in of integer constants in input file 1', COMPARE1.208
* A,LEN_IO,FIXHD1(101)) COMPARE1.209
CALL ABORT COMPARE1.210
ENDIF COMPARE1.211
COMPARE1.212
C Set missing data indicator to zero COMPARE1.213
DO I=1,FIXHD1(101) COMPARE1.214
IF(INTHD1(I).LT.0)INTHD1(I)=0 COMPARE1.215
ENDDO COMPARE1.216
COMPARE1.217
ROW_LENGTH1=INTHD1(6) COMPARE1.218
P_ROWS1=INTHD1(7) COMPARE1.219
P_FIELD1=ROW_LENGTH1*P_ROWS1 COMPARE1.220
AD311093.35
CL Extract maximum field size from LOOKUP header AD311093.36
CALL FIND_MAX_FIELD_SIZE(NFTIN1,FIXHD1(151),FIXHD1(152),FIXHD1 AD311093.37
& ,max_field_size1, wgdos_expand) UBC3F402.5
COMPARE1.221
CL 5. Buffer in integer constants from file 2 COMPARE1.222
COMPARE1.223
CALL BUFFIN(NFTIN2,INTHD2,FIXHD2(101),LEN_IO,A) COMPARE1.224
COMPARE1.225
C Check for I/O errors COMPARE1.226
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD2(101))THEN COMPARE1.227
CALL IOERROR('buffer in of integer constants in input file 2', COMPARE1.228
* A,LEN_IO,FIXHD2(101)) COMPARE1.229
CALL ABORT COMPARE1.230
ENDIF COMPARE1.231
COMPARE1.232
C Set missing data indicator to zero COMPARE1.233
DO I=1,FIXHD2(101) COMPARE1.234
IF(INTHD2(I).LT.0)INTHD2(I)=0 COMPARE1.235
ENDDO COMPARE1.236
COMPARE1.237
CL 6. Cause abort if files obviously different COMPARE1.238
COMPARE1.239
ROW_LENGTH2=INTHD2(6) COMPARE1.240
P_ROWS2=INTHD2(7) COMPARE1.241
P_FIELD2=ROW_LENGTH2*P_ROWS1 COMPARE1.242
AD311093.39
CL Extract maximum field size from LOOKUP header AD311093.40
CALL FIND_MAX_FIELD_SIZE(NFTIN2,FIXHD2(151),FIXHD2(152),FIXHD2 AD311093.41
& ,max_field_size2, wgdos_expand) UBC3F402.6
COMPARE1.243
IF(P_FIELD1.NE.P_FIELD2)THEN COMPARE1.244
WRITE(6,*)'COMPARE: ERROR Dumps are at different resolutions' COMPARE1.245
CALL ABORT COMPARE1.246
ENDIF COMPARE1.247
IF(LEN2_LOOKUP1.NE.LEN2_LOOKUP2)THEN COMPARE1.248
WRITE(6,*) DR221193.10
& 'COMPARE: WARNING Dumps have different number of fields' DR221193.11
ENDIF COMPARE1.251
COMPARE1.252
C Rewind files COMPARE1.253
CALL SETPOS(NFTIN1,0,ICODE) GTD0F400.45
CALL SETPOS(NFTIN2,0,ICODE) GTD0F400.46
COMPARE1.256
CL 7. Call COMPARE COMPARE1.257
COMPARE1.258
CALL COMPARE(LEN_FIXHD1,LEN_INTHD1,LEN_REALHD1, COMPARE1.259
& LEN1_LEVDEPC1,LEN2_LEVDEPC1,LEN1_ROWDEPC1, COMPARE1.260
& LEN2_ROWDEPC1,LEN1_COLDEPC1,LEN2_COLDEPC1, COMPARE1.261
& LEN1_FLDDEPC1,LEN2_FLDDEPC1,LEN_EXTCNST1, COMPARE1.262
& LEN_DUMPHIST1,LEN_CFI11,LEN_CFI21,LEN_CFI31, COMPARE1.263
& LEN1_LOOKUP1,LEN2_LOOKUP1,LEN_DATA1,P_FIELD1, COMPARE1.264
& LEN_FIXHD2,LEN_INTHD2,LEN_REALHD2, COMPARE1.265
& LEN1_LEVDEPC2,LEN2_LEVDEPC2,LEN1_ROWDEPC2, COMPARE1.266
& LEN2_ROWDEPC2,LEN1_COLDEPC2,LEN2_COLDEPC2, COMPARE1.267
& LEN1_FLDDEPC2,LEN2_FLDDEPC2,LEN_EXTCNST2, COMPARE1.268
& LEN_DUMPHIST2,LEN_CFI12,LEN_CFI22,LEN_CFI32, COMPARE1.269
& LEN1_LOOKUP2,LEN2_LOOKUP2,LEN_DATA2,P_FIELD2 COMPARE1.270
& ,NFTIN1,NFTIN2,MAX_FIELD_SIZE1,MAX_FIELD_SIZE2, UBC3F402.7
& wgdos_expand) UBC3F402.8
COMPARE1.272
COMPARE1.273
STOP COMPARE1.274
END COMPARE1.275
C*L Arguments:------------------------------------------------------- COMPARE1.276
SUBROUTINE COMPARE(LEN_FIXHD1,LEN_INTHD1,LEN_REALHD1, 1,41COMPARE1.277
& LEN1_LEVDEPC1,LEN2_LEVDEPC1,LEN1_ROWDEPC1, COMPARE1.278
& LEN2_ROWDEPC1,LEN1_COLDEPC1,LEN2_COLDEPC1, COMPARE1.279
& LEN1_FLDDEPC1,LEN2_FLDDEPC1,LEN_EXTCNST1, COMPARE1.280
& LEN_DUMPHIST1,LEN_CFI11,LEN_CFI21,LEN_CFI31, COMPARE1.281
& LEN1_LOOKUP1,LEN2_LOOKUP1,LEN_DATA1,P_FIELD1, COMPARE1.282
& LEN_FIXHD2,LEN_INTHD2,LEN_REALHD2, COMPARE1.283
& LEN1_LEVDEPC2,LEN2_LEVDEPC2,LEN1_ROWDEPC2, COMPARE1.284
& LEN2_ROWDEPC2,LEN1_COLDEPC2,LEN2_COLDEPC2, COMPARE1.285
& LEN1_FLDDEPC2,LEN2_FLDDEPC2,LEN_EXTCNST2, COMPARE1.286
& LEN_DUMPHIST2,LEN_CFI12,LEN_CFI22,LEN_CFI32, COMPARE1.287
& LEN1_LOOKUP2,LEN2_LOOKUP2,LEN_DATA2,P_FIELD2 COMPARE1.288
& ,NFTIN1,NFTIN2,MAX_FIELD_SIZE1,MAX_FIELD_SIZE2, UBC3F402.9
& wgdos_expand) UBC3F402.10
COMPARE1.290
IMPLICIT NONE COMPARE1.291
COMPARE1.292
INTEGER COMPARE1.293
& LEN_FIXHD1 !IN Length of fixed length header on file 1 COMPARE1.294
&,LEN_INTHD1 !IN Length of integer header on file 1 COMPARE1.295
&,LEN_REALHD1 !IN Length of real header on file 1 COMPARE1.296
&,LEN1_LEVDEPC1!IN 1st dim of lev dependent consts on file 1 COMPARE1.297
&,LEN2_LEVDEPC1!IN 2nd dim of lev dependent consts on file 1 COMPARE1.298
&,LEN1_ROWDEPC1!IN 1st dim of row dependent consts on file 1 COMPARE1.299
&,LEN2_ROWDEPC1!IN 2nd dim of row dependent consts on file 1 COMPARE1.300
&,LEN1_COLDEPC1!IN 1st dim of col dependent consts on file 1 COMPARE1.301
&,LEN2_COLDEPC1!IN 2nd dim of col dependent consts on file 1 COMPARE1.302
&,LEN1_FLDDEPC1!IN 1st dim of field dependent consts on file 1 COMPARE1.303
&,LEN2_FLDDEPC1!IN 2nd dim of field dependent consts on file 1 COMPARE1.304
&,LEN_EXTCNST1 !IN Length of extra consts on file 1 COMPARE1.305
&,LEN_DUMPHIST1!IN Length of history header on file 1 COMPARE1.306
&,LEN_CFI11 !IN Length of index1 on file 1 COMPARE1.307
&,LEN_CFI21 !IN Length of index2 on file 1 COMPARE1.308
&,LEN_CFI31 !IN Length of index3 on file 1 COMPARE1.309
&,LEN1_LOOKUP1 !IN 1st dim of LOOKUP on file 1 COMPARE1.310
&,LEN2_LOOKUP1 !IN 2nd dim of LOOKUP on file 1 COMPARE1.311
&,LEN_DATA1 !IN Length of data on file 1 COMPARE1.312
&,P_FIELD1 !IN No of p-points per level on file 1 COMPARE1.313
&,MAX_FIELD_SIZE1 !IN Maximum field size on file 1 AD311093.45
&,wgdos_expand ! IN set to 1 to expand WGDOS Fields for comparison UBC3F402.11
c UBC3F402.12
integer lblrec_1, lblrec_2, length_changed UBC3F402.13
COMPARE1.314
INTEGER COMPARE1.315
& LEN_FIXHD2 !IN Length of fixed length header on file 2 COMPARE1.316
&,LEN_INTHD2 !IN Length of integer header on file 2 COMPARE1.317
&,LEN_REALHD2 !IN Length of real header on file 2 COMPARE1.318
&,LEN1_LEVDEPC2!IN 1st dim of lev dependent consts on file 2 COMPARE1.319
&,LEN2_LEVDEPC2!IN 2nd dim of lev dependent consts on file 2 COMPARE1.320
&,LEN1_ROWDEPC2!IN 1st dim of row dependent consts on file 2 COMPARE1.321
&,LEN2_ROWDEPC2!IN 2nd dim of row dependent consts on file 2 COMPARE1.322
&,LEN1_COLDEPC2!IN 1st dim of col dependent consts on file 2 COMPARE1.323
&,LEN2_COLDEPC2!IN 2nd dim of col dependent consts on file 2 COMPARE1.324
&,LEN1_FLDDEPC2!IN 1st dim of field dependent consts on file 2 COMPARE1.325
&,LEN2_FLDDEPC2!IN 2nd dim of field dependent consts on file 2 COMPARE1.326
&,LEN_EXTCNST2 !IN Length of extra consts on file 2 COMPARE1.327
&,LEN_DUMPHIST2!IN Length of history header on file 2 COMPARE1.328
&,LEN_CFI12 !IN Length of index1 on file 2 COMPARE1.329
&,LEN_CFI22 !IN Length of index2 on file 2 COMPARE1.330
&,LEN_CFI32 !IN Length of index3 on file 2 COMPARE1.331
&,LEN1_LOOKUP2 !IN 1st dim of LOOKUP on file 2 COMPARE1.332
&,LEN2_LOOKUP2 !IN 2nd dim of LOOKUP on file 2 COMPARE1.333
&,LEN_DATA2 !IN Length of data on file 2 COMPARE1.334
&,P_FIELD2 !IN No of p-points per level on file 2 COMPARE1.335
&,MAX_FIELD_SIZE2 !IN Maximum field size on file 2 AD311093.46
COMPARE1.336
INTEGER COMPARE1.337
& NFTIN1 !IN Unit number for file 1 COMPARE1.338
&,NFTIN2 !IN Unit number for file 2 COMPARE1.339
COMPARE1.340
COMPARE1.341
C Comdecks: ------------------------------------------------------------ COMPARE1.342
*CALL CSUBMODL GDG0F401.143
*CALL CPPXREF GDG0F401.144
*CALL PPXLOOK GDG0F401.145
*CALL CLOOKADD GBC7F404.4
*CALL C_MDI GBC7F404.5
*CALL CSTASH GDG0F401.146
COMPARE1.344
C Local arrays:--------------------------------------------------------- COMPARE1.345
INTEGER COMPARE1.346
& FIXHD1(LEN_FIXHD1), ! COMPARE1.347
& INTHD1(LEN_INTHD1), !\ COMPARE1.348
& CFI11(LEN_CFI11+1),CFI21(LEN_CFI21+1), ! > file 1 headers COMPARE1.349
& CFI31(LEN_CFI31+1), !/ COMPARE1.350
& LOOKUP1(LEN1_LOOKUP1,LEN2_LOOKUP1) ! COMPARE1.351
COMPARE1.352
INTEGER COMPARE1.353
& FIXHD2(LEN_FIXHD2), ! COMPARE1.354
& INTHD2(LEN_INTHD2), !\ COMPARE1.355
& CFI12(LEN_CFI12+1),CFI22(LEN_CFI22+1), ! > file 2 headers COMPARE1.356
& CFI32(LEN_CFI32+1), !/ COMPARE1.357
& LOOKUP2(LEN1_LOOKUP2,LEN2_LOOKUP2) ! COMPARE1.358
COMPARE1.359
REAL COMPARE1.360
& REALHD1(LEN_REALHD1), ! COMPARE1.361
& LEVDEPC1(1+LEN1_LEVDEPC1*LEN2_LEVDEPC1), ! COMPARE1.362
& ROWDEPC1(1+LEN1_ROWDEPC1*LEN2_ROWDEPC1), !\ COMPARE1.363
& COLDEPC1(1+LEN1_COLDEPC1*LEN2_COLDEPC1), ! > file 1 headers COMPARE1.364
& FLDDEPC1(1+LEN1_FLDDEPC1*LEN2_FLDDEPC1), !/ COMPARE1.365
& EXTCNST1(LEN_EXTCNST1+1), ! COMPARE1.366
& DUMPHIST1(LEN_DUMPHIST1+1), ! COMPARE1.367
& R_D1(MAX_FIELD_SIZE1) ! REAL Array for field on file 1 GPB2F401.10
GPB2F401.11
INTEGER GPB2F401.12
& I_D1(MAX_FIELD_SIZE1) ! INTEGER Array for field on file 1 GPB2F401.13
GPB2F401.14
LOGICAL GPB2F401.15
& L_D1(MAX_FIELD_SIZE1) ! LOGICAL Array for field on file 1 GPB2F401.16
COMPARE1.369
REAL COMPARE1.370
& REALHD2(LEN_REALHD2), ! COMPARE1.371
& LEVDEPC2(1+LEN1_LEVDEPC2*LEN2_LEVDEPC2), ! COMPARE1.372
& ROWDEPC2(1+LEN1_ROWDEPC2*LEN2_ROWDEPC2), !\ COMPARE1.373
& COLDEPC2(1+LEN1_COLDEPC2*LEN2_COLDEPC2), ! > file 2 headers COMPARE1.374
& FLDDEPC2(1+LEN1_FLDDEPC2*LEN2_FLDDEPC2), !/ COMPARE1.375
& EXTCNST2(LEN_EXTCNST2+1), ! COMPARE1.376
& DUMPHIST2(LEN_DUMPHIST2+1), ! COMPARE1.377
& R_D2(MAX_FIELD_SIZE2) ! REAL Array for field on file 2 GPB2F401.17
GPB2F401.18
INTEGER GPB2F401.19
& I_D2(MAX_FIELD_SIZE1) ! INTEGER Array for field on file 2 GPB2F401.20
GPB2F401.21
LOGICAL GPB2F401.22
& L_D2(MAX_FIELD_SIZE1) ! LOGICAL Array for field on file 2 GPB2F401.23
COMPARE1.379
INTEGER COMPARE1.380
* PP_XREF(PPXREF_CODELEN) !PPXREF codes for a given section/item COMPARE1.381
COMPARE1.382
C External subroutines called:------------------------------------------ COMPARE1.383
EXTERNAL ABORT,ABORT_IO,READHEAD,READFLDS,HDPPXRF,GETPPX GDG0F401.147
C*---------------------------------------------------------------------- COMPARE1.385
C*L Local variables:--------------------------------------------------- COMPARE1.386
REAL COMPARE1.387
* MAX_DIFF ! Maximum difference between two real fields DR221193.12
*,RD1,RD2 ! Real variables to equivalent with LD1/ID1 & LD2/ID2 DR221193.13
REAL DIFF_PER,RMS_F1,RMS_F2,RMS_DIFF GPB2F401.6
GPB2F401.7
*IF DEF,T3E GBC7F404.141
COMPARE1.389
integer jrc_nan UDG2F402.5
c UDG2F402.6
integer jrc_mask UDG2F402.7
integer deb_mask UDG2F402.8
c UDG2F402.9
data jrc_mask/X'7FF0000000000000'/ UDG2F402.10
data deb_mask/X'FFF0000000000000'/ UDG2F402.11
c UDG2F402.12
*ENDIF GBC7F404.142
INTEGER COMPARE1.390
& ICODE ! Error return code from subroutines COMPARE1.391
&,START_BLOCK ! READHEAD argument (not used) COMPARE1.392
&,I,J,K,L,M,N ! Loop indices UDG2F405.14
&,JMIN ! Minimum length of two headers COMPARE1.394
&,S_ITEM_CODE ! STASH item code GBC7F404.6
&,SECTION ! STASH section number COMPARE1.396
&,ID1,ID2 ! Integer variables to equivalent with RD1 and RD2 DR221193.14
&,N_DIFF ! No of differences to be listed DR221193.15
*,IMAX_DIFF ! Maximum difference between two integer fields DR221193.16
*,PACK_CODE1 ! Packing code for LOOKUP table 1 DR221193.17
*,PACK_CODE2 ! Packing code for LOOKUP table 2 DR221193.18
&,MAX_J ! Location of max.diff UDG1F403.21
INTEGER RowNumber GDG0F401.148
INTEGER MODEL !Internal model number UDG2F305.10
INTEGER LEN_FIELD !Number of points in field to be UDG1F400.5
!compared UDG1F400.6
INTEGER N1,N2 UDG2F405.15
INTEGER OFFSET1 UDG2F405.16
INTEGER OFFSET2 UDG2F405.17
INTEGER NUMREC1 UDG2F405.18
INTEGER NUMREC2 UDG2F405.19
INTEGER NMISSING1 UDG2F405.20
INTEGER NMISSING2 UDG2F405.21
INTEGER IROWDEPC1 UDG2F405.22
INTEGER IROWDEPC2 UDG2F405.23
INTEGER INDEX(LEN2_LOOKUP1) UDG2F405.24
INTEGER NDIFFER(LEN2_LOOKUP1) UDG2F405.25
LOGICAL LMISSING1(LEN2_LOOKUP1) UDG2F405.26
LOGICAL LMISSING2(LEN2_LOOKUP2) UDG2F405.27
INTEGER EXPPXI GDG0F401.149
CHARACTER*36 EXPPXC GDG0F401.150
DR221193.19
LOGICAL DR221193.20
& LD1,LD2 ! Logical variables to equivalent with RD1 and RD2 DR221193.21
COMPARE1.397
CHARACTER COMPARE1.398
& CMESSAGE*100 ! Character string returned if ICODE .ne. 0 COMPARE1.399
*,PHRASE*(PPXREF_CHARLEN) ! Name of field COMPARE1.400
CHARACTER*1 DIFF(MAX_FIELD_SIZE1) GPB2F401.8
CHARACTER*200 KEY GPB2F401.9
CHARACTER*80 FILENAME ! Name of output file GGH4F401.1
DR221193.22
EQUIVALENCE (RD1,ID1,LD1) , (RD2,ID2,LD2) DR221193.23
DR221193.24
PARAMETER (N_DIFF=10) DR221193.25
INTEGER NFT1,NFT2 GDG0F401.141
PARAMETER (NFT1=22, NFT2=2) GDG0F401.142
C*---------------------------------------------------------------------- COMPARE1.401
COMPARE1.402
! 0. Open PPXREF file UDG2F305.13
UDG2F305.14
ppxRecs=1 GDG0F401.151
RowNumber=0 GDG0F401.152
cmessage = ' ' GDW1F404.163
ICODE=0 UDG9F404.5
CALL HDPPXRF(NFT1,'STASHmaster_A',ppxRecs,ICODE,CMESSAGE) GDG0F401.153
IF(ICODE.GT.0)THEN UDG9F404.6
WRITE(6,*) 'Error reading STASHmaster_A' UDG9F404.7
WRITE(6,*) CMESSAGE UDG9F404.8
CALL ABORT UDG9F404.9
END IF UDG9F404.10
CALL HDPPXRF(NFT1,'STASHmaster_O',ppxRecs,ICODE,CMESSAGE) GDG0F401.154
IF(ICODE.GT.0)THEN UDG9F404.11
WRITE(6,*) 'Error reading STASHmaster_O' UDG9F404.12
WRITE(6,*) CMESSAGE UDG9F404.13
CALL ABORT UDG9F404.14
END IF UDG9F404.15
CALL HDPPXRF(NFT1,'STASHmaster_S',ppxRecs,ICODE,CMESSAGE) GDG0F401.155
IF(ICODE.GT.0)THEN UDG9F404.16
WRITE(6,*) 'Error reading STASHmaster_S' UDG9F404.17
WRITE(6,*) CMESSAGE UDG9F404.18
CALL ABORT UDG9F404.19
END IF UDG9F404.20
CALL HDPPXRF(NFT1,'STASHmaster_W',ppxRecs,ICODE,CMESSAGE) GDG0F401.156
IF(ICODE.GT.0)THEN GDW1F404.164
WRITE(6,*) 'Error reading STASHmaster_W' UDG9F404.21
WRITE(6,*) CMESSAGE GDG0F401.158
CALL ABORT GDG0F401.159
ENDIF GDG0F401.160
GDG0F401.161
CALL GETPPX(NFT1,NFT2,'STASHmaster_A',RowNumber, GDG0F401.162
*CALL ARGPPX GDG0F401.163
& ICODE,CMESSAGE) GDG0F401.164
CALL GETPPX(NFT1,NFT2,'STASHmaster_O',RowNumber, GDG0F401.165
*CALL ARGPPX GDG0F401.166
& ICODE,CMESSAGE) GDG0F401.167
CALL GETPPX(NFT1,NFT2,'STASHmaster_S',RowNumber, GDG0F401.168
*CALL ARGPPX GDG0F401.169
& ICODE,CMESSAGE) GDG0F401.170
CALL GETPPX(NFT1,NFT2,'STASHmaster_W',RowNumber, GDG0F401.171
*CALL ARGPPX GDG0F401.172
& ICODE,CMESSAGE) GDG0F401.173
IF(ICODE.NE.0)THEN GDG0F401.174
WRITE(6,*) CMESSAGE GDG0F401.175
CALL ABORT GDG0F401.176
ENDIF GDG0F401.177
GDG0F401.178
!User STASHmaster GDG0F401.179
CALL HDPPXRF(0,' ',ppxRecs,ICODE,CMESSAGE) GDG0F401.180
IF(ICODE.NE.0)THEN GDG0F401.181
WRITE(6,*) CMESSAGE GDG0F401.182
CALL ABORT GDG0F401.183
ENDIF GDG0F401.184
CALL GETPPX(0,NFT2,' ',RowNumber, GDG0F401.185
*CALL ARGPPX GDG0F401.186
& ICODE,CMESSAGE) GDG0F401.187
IF(ICODE.NE.0)THEN GDG0F401.188
WRITE(6,*) CMESSAGE GDG0F401.189
CALL ABORT GDG0F401.190
ENDIF GDG0F401.191
! 1: Open output files UDG2F405.28
! UDG2F405.29
! Open up unit 7: Summary part one UDG2F405.30
CALL GET_FILE(7,FILENAME,80,ICODE) UDG2F405.31
OPEN(7,FILE=FILENAME,STATUS='NEW',IOSTAT=ICODE) UDG2F405.32
IF (ICODE.NE.0) THEN UDG2F405.33
WRITE(6,*) 'Can not write to ',FILENAME UDG2F405.34
ELSE UDG2F405.35
WRITE(6,*) 'OPEN: 7:',FILENAME,'has been created' UDG2F405.36
ENDIF UDG2F405.37
WRITE(7,*)' COMPARE - SUMMARY MODE' UDG2F405.38
WRITE(7,*)'-----------------------' UDG2F405.39
WRITE(7,*)' ' UDG2F405.40
UDG2F405.41
! Open up unit 8: Summary part two UDG2F405.42
CALL GET_FILE(8,FILENAME,80,ICODE) UDG2F405.43
OPEN(8,FILE=FILENAME,STATUS='NEW',IOSTAT=ICODE) UDG2F405.44
IF (ICODE.NE.0) THEN UDG2F405.45
WRITE(6,*) 'Can not write to ',FILENAME UDG2F405.46
ELSE UDG2F405.47
WRITE(6,*) 'OPEN: 8:',FILENAME,'has been created' UDG2F405.48
ENDIF UDG2F405.49
UDG2F405.50
! Open up unit 10 UDG2F405.51
CALL GET_FILE(10,FILENAME,80,ICODE) UDG2F405.52
OPEN(10,FILE=FILENAME,STATUS='NEW',IOSTAT=ICODE) UDG2F405.53
IF (ICODE.NE.0) THEN UDG2F405.54
WRITE(6,*) 'Can not write to ',FILENAME UDG2F405.55
ELSE UDG2F405.56
WRITE(6,*) 'OPEN: 10:',FILENAME,'has been created' UDG2F405.57
ENDIF UDG2F405.58
WRITE(10,*)' COMPARE - DIFFERENCE CHARTS' UDG2F405.59
WRITE(10,*)'----------------------------' UDG2F405.60
WRITE(10,*)' ' UDG2F405.61
COMPARE1.404
WRITE(6,*)' ' COMPARE1.405
WRITE(6,*)' FILE 1' COMPARE1.406
WRITE(6,*)' ------' COMPARE1.407
CALL READHEAD(NFTIN1,FIXHD1,LEN_FIXHD1, COMPARE1.408
& INTHD1,LEN_INTHD1, COMPARE1.409
& REALHD1,LEN_REALHD1, COMPARE1.410
& LEVDEPC1,LEN1_LEVDEPC1,LEN2_LEVDEPC1, COMPARE1.411
& ROWDEPC1,LEN1_ROWDEPC1,LEN2_ROWDEPC1, COMPARE1.412
& COLDEPC1,LEN1_COLDEPC1,LEN2_COLDEPC1, COMPARE1.413
& FLDDEPC1,LEN1_FLDDEPC1,LEN2_FLDDEPC1, COMPARE1.414
& EXTCNST1,LEN_EXTCNST1, COMPARE1.415
& DUMPHIST1,LEN_DUMPHIST1, COMPARE1.416
& CFI11,LEN_CFI11, COMPARE1.417
& CFI21,LEN_CFI21, COMPARE1.418
& CFI31,LEN_CFI31, COMPARE1.419
& LOOKUP1,LEN1_LOOKUP1,LEN2_LOOKUP1, COMPARE1.420
& LEN_DATA1, COMPARE1.421
*CALL ARGPPX GDG0F401.192
& START_BLOCK,ICODE,CMESSAGE) COMPARE1.422
COMPARE1.423
IF(ICODE.NE.0)THEN COMPARE1.424
WRITE(6,*)CMESSAGE,ICODE COMPARE1.425
CALL ABORT COMPARE1.426
ENDIF COMPARE1.427
COMPARE1.428
CL 2. Read in file 2 header COMPARE1.429
COMPARE1.430
WRITE(6,*)' ' COMPARE1.431
WRITE(6,*)' FILE 2' COMPARE1.432
WRITE(6,*)' ------' COMPARE1.433
CALL READHEAD(NFTIN2,FIXHD2,LEN_FIXHD2, COMPARE1.434
& INTHD2,LEN_INTHD2, COMPARE1.435
& REALHD2,LEN_REALHD2, COMPARE1.436
& LEVDEPC2,LEN1_LEVDEPC2,LEN2_LEVDEPC2, COMPARE1.437
& ROWDEPC2,LEN1_ROWDEPC2,LEN2_ROWDEPC2, COMPARE1.438
& COLDEPC2,LEN1_COLDEPC2,LEN2_COLDEPC2, COMPARE1.439
& FLDDEPC2,LEN1_FLDDEPC2,LEN2_FLDDEPC2, COMPARE1.440
& EXTCNST2,LEN_EXTCNST2, COMPARE1.441
& DUMPHIST2,LEN_DUMPHIST2, COMPARE1.442
& CFI12,LEN_CFI12, COMPARE1.443
& CFI22,LEN_CFI22, COMPARE1.444
& CFI32,LEN_CFI32, COMPARE1.445
& LOOKUP2,LEN1_LOOKUP2,LEN2_LOOKUP2, COMPARE1.446
& LEN_DATA2, COMPARE1.447
*CALL ARGPPX GDG0F401.193
& START_BLOCK,ICODE,CMESSAGE) COMPARE1.448
COMPARE1.449
COMPARE1.450
IF(ICODE.NE.0)THEN COMPARE1.451
WRITE(6,*)CMESSAGE,ICODE COMPARE1.452
CALL ABORT COMPARE1.453
ENDIF COMPARE1.454
COMPARE1.455
CL 3. Compare fixed length headers COMPARE1.456
COMPARE1.457
IF(FIXHD1(5).NE.FIXHD2(5))THEN UDG2F405.62
WRITE(6,'(''WARNING: FIXHD1(5) = '',I3,'' FIXHD2(5) = '',I3)') UDG2F405.63
& FIXHD1(5),FIXHD2(5) UDG2F405.64
WRITE(7,'(''WARNING: FIXHD1(5) = '',I3,'' FIXHD2(5) = '',I3)') UDG2F405.65
& FIXHD1(5),FIXHD2(5) UDG2F405.66
WRITE(6,'('' File types are different'')') UDG2F405.67
WRITE(7,'('' File types are different'')') UDG2F405.68
END IF UDG2F405.69
WRITE(6,*)' ' COMPARE1.458
WRITE(6,*)'FIXED LENGTH HEADER:' COMPARE1.459
UDG2F405.70
! Check length of fixed length headers UDG2F405.71
JMIN=MIN0(LEN_FIXHD1,LEN_FIXHD2) UDG2F405.72
IF(LEN_FIXHD1.NE.LEN_FIXHD2)THEN UDG2F405.73
WRITE(6,'(''WARNING: LEN_FIXHD1 = '',I3,'' LEN_FIXHD2 = '',I3)') UDG2F405.74
& LEN_FIXHD1,LEN_FIXHD2 UDG2F405.75
WRITE(7,'(''WARNING: LEN_FIXHD1 = '',I3,'' LEN_FIXHD2 = '',I3)') UDG2F405.76
& LEN_FIXHD1,LEN_FIXHD2 UDG2F405.77
WRITE(6,'('' Fixed length headers have different '', UDG2F405.78
& ''lengths'')') UDG2F405.79
WRITE(7,'('' Fixed length headers have different '', UDG2F405.80
& ''lengths'')') UDG2F405.81
WRITE(6,'('' Comparing first '',I3,''elements only'')') UDG2F405.82
& JMIN UDG2F405.83
WRITE(7,'('' Comparing first '',I3,''elements only'')') UDG2F405.84
& JMIN UDG2F405.85
END IF UDG2F405.86
UDG2F405.87
! Check fixed length header UDG2F405.88
IF(FIXHD1(152).EQ.FIXHD2(152))THEN UDG2F405.89
IF(FIXHD1(160).NE.FIXHD2(160))THEN UDG2F405.90
WRITE(6,'(''WARNING: LEN1 = '',i9,'' and LEN2 = '',i9)') PXCOMP.1
& FIXHD1(160),FIXHD2(160) UDG2F405.92
WRITE(7,'(''WARNING: LEN1 = '',i9,'' and LEN2 = '',i9)') PXCOMP.2
& FIXHD1(160),FIXHD2(160) UDG2F405.94
WRITE(6,'('' Data start address differs'')') UDG2F405.95
WRITE(7,'('' Data start address differs'')') UDG2F405.96
WRITE(6,'('' Possibly due to comparing old and new '', UDG2F405.97
& ''format UM dumps or fieldsfiles'')') UDG2F405.98
WRITE(7,'('' Possibly due to comparing old and new '', UDG2F405.99
& ''format UM dumps or fieldsfiles'')') UDG2F405.100
ELSE IF(FIXHD1(161).NE.FIXHD2(161))THEN UDG2F405.101
WRITE(6,'(''WARNING: LEN1 = '',i9,'' and LEN2 = '',i9)') PXCOMP.3
& FIXHD1(161),FIXHD2(161) UDG2F405.103
WRITE(7,'(''WARNING: LEN1 = '',i9,'' and LEN2 = '',i9)') PXCOMP.4
& FIXHD1(161),FIXHD2(161) UDG2F405.105
WRITE(6,'('' Length of data differs'')') UDG2F405.106
WRITE(7,'('' Length of data differs'')') UDG2F405.107
WRITE(6,'('' Possibly due to comparing old and new '', UDG2F405.108
& ''format UM dumps or fieldsfiles'')') UDG2F405.109
WRITE(7,'('' Possibly due to comparing old and new '', UDG2F405.110
& ''format UM dumps or fieldsfiles'')') UDG2F405.111
END IF UDG2F405.112
END IF UDG2F405.113
UDG2F405.114
K = 0 UDG2F405.115
length_changed=0 UBC3F402.14
DO I=1,JMIN COMPARE1.464
IF(FIXHD1(I).NE.FIXHD2(I))THEN COMPARE1.465
WRITE(6,'(''ITEM = '',i4,'' Values = '',i7,'' and '',i7)') UDG2F405.116
& i, fixhd1(i), fixhd2(i) UDG2F405.117
K = K + 1 UDG2F405.118
ENDIF COMPARE1.467
ENDDO COMPARE1.468
UDG2F405.119
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.120
WRITE(8,*) 'FIXED LENGTH HEADER: ', UDG2F405.121
& 'Number of differences = ',K UDG2F405.122
COMPARE1.469
CL 4. Compare integer headers COMPARE1.470
COMPARE1.471
IF(LEN_INTHD1.GT.0.OR.LEN_INTHD2.GT.0)THEN COMPARE1.472
WRITE(6,*)' ' COMPARE1.473
WRITE(6,*)'INTEGER HEADER:' COMPARE1.474
IF(LEN_INTHD1.NE.LEN_INTHD2)THEN COMPARE1.475
WRITE(6,*)'WARNING LEN1=',LEN_INTHD1,' LEN2=',LEN_INTHD2 COMPARE1.476
ENDIF COMPARE1.477
JMIN=MIN0(LEN_INTHD1,LEN_INTHD2) COMPARE1.478
K=0 COMPARE1.479
DO I=1,JMIN COMPARE1.480
IF(INTHD1(I).NE.INTHD2(I))THEN COMPARE1.481
K=K+1 COMPARE1.482
WRITE(6,*)'ITEM=',I,INTHD1(I),INTHD2(I) COMPARE1.483
ENDIF COMPARE1.484
ENDDO COMPARE1.485
ENDIF COMPARE1.486
UDG2F405.123
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.124
WRITE(8,*) 'INTEGER HEADER: ', UDG2F405.125
& 'Number of differences = ',K UDG2F405.126
L=K COMPARE1.488
COMPARE1.489
CL 5. Compare real headers COMPARE1.490
COMPARE1.491
IF(LEN_REALHD1.GT.0.OR.LEN_REALHD2.GT.0)THEN COMPARE1.492
WRITE(6,*)' ' COMPARE1.493
WRITE(6,*)'REAL HEADER:' COMPARE1.494
IF(LEN_REALHD1.NE.LEN_REALHD2)THEN COMPARE1.495
WRITE(6,*)'WARNING LEN1=',LEN_REALHD1,' LEN2=',LEN_REALHD2 COMPARE1.496
ENDIF COMPARE1.497
JMIN=MIN0(LEN_REALHD1,LEN_REALHD2) COMPARE1.498
K=0 COMPARE1.499
DO I=1,JMIN COMPARE1.500
*IF DEF,T3E GAV0F405.15
IF(XOR(REALHD1(I),REALHD2(I)).NE.0) THEN GAV0F405.16
*ELSE GAV0F405.17
IF(REALHD1(I).NE.REALHD2(I))THEN GAV0F405.18
*ENDIF GAV0F405.19
K=K+1 COMPARE1.502
WRITE(6,*)'ITEM=',I,REALHD1(I),REALHD2(I) COMPARE1.503
ENDIF COMPARE1.504
ENDDO COMPARE1.505
ENDIF COMPARE1.506
UDG2F405.127
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.128
WRITE(8,*) 'REAL HEADER: ', UDG2F405.129
& 'Number of differences = ',K UDG2F405.130
L=L+K COMPARE1.508
COMPARE1.509
CL 6. Compare level dependent constants COMPARE1.510
COMPARE1.511
WRITE(6,*)' ' UDR2F304.3
WRITE(6,*)'LEVEL DEPENDENT CONSTS:' UDR2F304.4
IF(FIXHD1(110).GT.0 .AND. FIXHD2(110).GT.0) THEN UDR2F304.5
IF(LEN1_LEVDEPC1.NE.LEN1_LEVDEPC2)THEN COMPARE1.512
WRITE(6,*)'ERROR : different number of levels' UDR2F304.6
WRITE(6,*)'LEV1=',LEN1_LEVDEPC1,' LEV2=',LEN1_LEVDEPC2 COMPARE1.514
CALL ABORT COMPARE1.515
ELSEIF(LEN2_LEVDEPC1.GT.0.OR.LEN2_LEVDEPC2.GT.0)THEN UDR2F304.7
IF(LEN2_LEVDEPC1.NE.LEN2_LEVDEPC2)THEN COMPARE1.520
WRITE(6,*)'WARNING LEN1=',LEN2_LEVDEPC1,' LEN2=',LEN2_LEVDEPC2 COMPARE1.521
ENDIF COMPARE1.522
JMIN=MIN0(LEN2_LEVDEPC1,LEN2_LEVDEPC2) COMPARE1.523
K=0 COMPARE1.524
DO I=1,JMIN COMPARE1.525
DO J=1,LEN1_LEVDEPC1 COMPARE1.526
*IF DEF,T3E GAV0F405.20
IF(XOR(LEVDEPC1((I-1)*LEN1_LEVDEPC1+J), GAV0F405.21
& LEVDEPC2((I-1)*LEN1_LEVDEPC1+J)).NE.0)THEN GAV0F405.22
*ELSE GAV0F405.23
IF(LEVDEPC1((I-1)*LEN1_LEVDEPC1+J).NE. GAV0F405.24
& LEVDEPC2((I-1)*LEN1_LEVDEPC1+J))THEN GAV0F405.25
*ENDIF GAV0F405.26
K=K+1 COMPARE1.529
WRITE(6,*)'LEVEL=',J,'ITEM=',I, COMPARE1.530
& LEVDEPC1((I-1)*LEN1_LEVDEPC1+J), COMPARE1.531
& LEVDEPC2((I-1)*LEN1_LEVDEPC1+J) COMPARE1.532
ENDIF COMPARE1.533
ENDDO COMPARE1.534
ENDDO COMPARE1.535
UDG2F405.131
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.132
WRITE(8,*) 'LEVEL DEPENDENT CONSTANTS: ', UDG2F405.133
& 'Number of differences = ',K UDG2F405.134
L=L+K COMPARE1.537
ENDIF COMPARE1.538
ELSE UDR2F304.8
WRITE(6,*)'No comparison done' UDR2F304.9
IF (FIXHD1(110).LE.0) WRITE(6,*)'No array in FILE 1' UDR2F304.10
IF (FIXHD2(110).LE.0) WRITE(6,*)'No array in FILE 2' UDR2F304.11
ENDIF UDR2F304.12
COMPARE1.539
CL 7. Compare row dependent constants COMPARE1.540
COMPARE1.541
WRITE(6,*)' ' UDR2F304.13
WRITE(6,*)'ROW DEPENDENT CONSTS:' UDR2F304.14
IF(FIXHD1(115).GT.0 .AND. FIXHD2(115).GT.0) THEN UDR2F304.15
IF(LEN1_ROWDEPC1.NE.LEN1_ROWDEPC2)THEN COMPARE1.542
WRITE(6,*)'ERROR : different number of rows' UDR2F304.16
WRITE(6,*)'ROW1=',LEN1_ROWDEPC1,' ROW2=',LEN1_ROWDEPC2 COMPARE1.544
CALL ABORT COMPARE1.545
ELSEIF(LEN2_ROWDEPC1.GT.0.OR.LEN2_ROWDEPC2.GT.0)THEN UDR2F304.17
IF(LEN2_ROWDEPC1.NE.LEN2_ROWDEPC2)THEN COMPARE1.550
WRITE(6,*)'WARNING different second dimension' UDR2F304.18
WRITE(6,*)'LEN1=',LEN2_ROWDEPC1,' LEN2=',LEN2_ROWDEPC2 UDR2F304.19
ENDIF COMPARE1.552
JMIN=MIN0(LEN2_ROWDEPC1,LEN2_ROWDEPC2) COMPARE1.553
K=0 COMPARE1.554
DO I=1,JMIN COMPARE1.555
DO J=1,LEN1_ROWDEPC1 COMPARE1.556
*IF DEF,T3E GAV0F405.27
IF(XOR(ROWDEPC1((I-1)*LEN1_ROWDEPC1+J), GAV0F405.28
& ROWDEPC2((I-1)*LEN1_ROWDEPC1+J)).NE.0)THEN GAV0F405.29
*ELSE GAV0F405.30
IF(ROWDEPC1((I-1)*LEN1_ROWDEPC1+J).NE. GAV0F405.31
& ROWDEPC2((I-1)*LEN1_ROWDEPC1+J))THEN GAV0F405.32
*ENDIF GAV0F405.33
K=K+1 COMPARE1.559
WRITE(6,*)'ROW=',I,'ITEM=',J, COMPARE1.560
& ROWDEPC1((I-1)*LEN1_ROWDEPC1+J), COMPARE1.561
& ROWDEPC2((I-1)*LEN1_ROWDEPC1+J) COMPARE1.562
ENDIF COMPARE1.563
ENDDO COMPARE1.564
ENDDO COMPARE1.565
UDG2F405.135
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.136
WRITE(8,*) 'ROW DEPENDENT CONSTANTS: ', UDG2F405.137
& 'Number of differences = ',K UDG2F405.138
L=L+K COMPARE1.567
ENDIF COMPARE1.568
ELSE UDR2F304.20
WRITE(6,*)'No comparison done' UDR2F304.21
IF (FIXHD1(115).LE.0) WRITE(6,*)'No array in FILE 1' UDR2F304.22
IF (FIXHD2(115).LE.0) WRITE(6,*)'No array in FILE 2' UDR2F304.23
ENDIF UDR2F304.24
COMPARE1.569
CL 8. Compare column dependent constants COMPARE1.570
COMPARE1.571
WRITE(6,*)' ' UDR2F304.25
WRITE(6,*)'COLUMN DEPENDENT CONSTS:' UDR2F304.26
IF(FIXHD1(120).GT.0 .AND. FIXHD2(120).GT.0) THEN UDR2F304.27
IF(LEN1_COLDEPC1.NE.LEN1_COLDEPC2)THEN COMPARE1.572
WRITE(6,*)'ERROR : different number of columns.' UDR2F304.28
WRITE(6,*)'COL1=',LEN1_COLDEPC1,' COL2=',LEN1_COLDEPC2 UDR2F304.29
CALL ABORT COMPARE1.575
ELSEIF(LEN2_COLDEPC1.GT.0.OR.LEN2_COLDEPC2.GT.0)THEN UDR2F304.30
IF(LEN2_COLDEPC1.NE.LEN2_COLDEPC2)THEN COMPARE1.580
WRITE(6,*)'WARNING LEN1=',LEN2_COLDEPC1,' LEN2=',LEN2_COLDEPC2 COMPARE1.581
ENDIF COMPARE1.582
JMIN=MIN0(LEN2_COLDEPC1,LEN2_COLDEPC2) COMPARE1.583
K=0 COMPARE1.584
DO I=1,JMIN COMPARE1.585
DO J=1,LEN1_COLDEPC1 COMPARE1.586
*IF DEF,T3E GAV0F405.34
IF(XOR(COLDEPC1((I-1)*LEN1_COLDEPC1+J), GAV0F405.35
& COLDEPC2((I-1)*LEN1_COLDEPC1+J)).NE.0) THEN GAV0F405.36
*ELSE GAV0F405.37
IF(COLDEPC1((I-1)*LEN1_COLDEPC1+J).NE. GAV0F405.38
& COLDEPC2((I-1)*LEN1_COLDEPC1+J))THEN GAV0F405.39
*ENDIF GAV0F405.40
K=K+1 COMPARE1.589
WRITE(6,*)'COL=',I,'ITEM=',J, COMPARE1.590
& COLDEPC1((I-1)*LEN1_COLDEPC1+J), COMPARE1.591
& COLDEPC2((I-1)*LEN1_COLDEPC1+J) COMPARE1.592
ENDIF COMPARE1.593
ENDDO COMPARE1.594
ENDDO COMPARE1.595
UDG2F405.139
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.140
WRITE(8,*) 'COLUMN DEPENDENT CONSTANTS: ', UDG2F405.141
& 'Number of differences = ',K UDG2F405.142
L=L+K COMPARE1.597
ENDIF COMPARE1.598
ELSE UDR2F304.31
WRITE(6,*)'No comparison done' UDR2F304.32
IF (FIXHD1(120).LE.0) WRITE(6,*)'No array in FILE 1' UDR2F304.33
IF (FIXHD2(120).LE.0) WRITE(6,*)'No array in FILE 2' UDR2F304.34
ENDIF UDR2F304.35
COMPARE1.599
CL 9. Compare field dependent constants COMPARE1.600
COMPARE1.601
WRITE(6,*)' ' UDR2F304.36
WRITE(6,*)'FIELD DEPENDENT CONSTS:' UDR2F304.37
IF(FIXHD1(125).GT.0 .AND. FIXHD2(125).GT.0) THEN UDR2F304.38
IF(LEN1_FLDDEPC1.NE.LEN1_FLDDEPC2)THEN COMPARE1.602
WRITE(6,*)'ERROR : different number of fields.' UDR2F304.39
WRITE(6,*)'FLD1=',LEN1_FLDDEPC1,' FLD2=',LEN1_FLDDEPC2 COMPARE1.604
CALL ABORT COMPARE1.605
ELSEIF(LEN2_FLDDEPC1.GT.0.OR.LEN2_FLDDEPC2.GT.0)THEN UDR2F304.40
IF(LEN2_FLDDEPC1.NE.LEN2_FLDDEPC2)THEN COMPARE1.610
WRITE(6,*)'WARNING LEN1=',LEN2_FLDDEPC1,' LEN2=',LEN2_FLDDEPC2 COMPARE1.611
ENDIF COMPARE1.612
JMIN=MIN0(LEN2_FLDDEPC1,LEN2_FLDDEPC2) COMPARE1.613
K=0 COMPARE1.614
DO I=1,JMIN COMPARE1.615
DO J=1,LEN1_FLDDEPC1 COMPARE1.616
*IF DEF,T3E GAV0F405.41
IF(XOR(FLDDEPC1((I-1)*LEN1_FLDDEPC1+J), GAV0F405.42
& FLDDEPC2((I-1)*LEN1_FLDDEPC1+J)).NE.0) THEN GAV0F405.43
*ELSE GAV0F405.44
IF(FLDDEPC1((I-1)*LEN1_FLDDEPC1+J).NE. GAV0F405.45
& FLDDEPC2((I-1)*LEN1_FLDDEPC1+J))THEN GAV0F405.46
*ENDIF GAV0F405.47
K=K+1 COMPARE1.619
WRITE(6,*)'FIELD=',J,'ITEM=',I, COMPARE1.620
& FLDDEPC1((I-1)*LEN1_FLDDEPC1+J), COMPARE1.621
& FLDDEPC2((I-1)*LEN1_FLDDEPC1+J) COMPARE1.622
ENDIF COMPARE1.623
ENDDO COMPARE1.624
ENDDO COMPARE1.625
UDG2F405.143
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.144
WRITE(8,*) 'FIELD DEPENDENT CONSTANTS: ', UDG2F405.145
& 'Number of differences = ',K UDG2F405.146
UDG2F405.147
L=L+K COMPARE1.627
ENDIF COMPARE1.628
ELSE UDR2F304.41
WRITE(6,*)'No comparison done' UDR2F304.42
IF (FIXHD1(125).LE.0) WRITE(6,*)'No array in FILE 1' UDR2F304.43
IF (FIXHD2(125).LE.0) WRITE(6,*)'No array in FILE 2' UDR2F304.44
ENDIF UDR2F304.45
COMPARE1.629
CL 10. Compare extra constants COMPARE1.630
COMPARE1.631
WRITE(6,*)' ' UDR2F304.46
WRITE(6,*)'EXTRA CONSTANTS:' UDR2F304.47
IF(FIXHD1(130).GT.0 .AND. FIXHD2(130).GT.0) THEN UDR2F304.48
IF(LEN_EXTCNST1.GT.0.OR.LEN_EXTCNST2.GT.0)THEN COMPARE1.632
IF(LEN_EXTCNST1.NE.LEN_EXTCNST2)THEN COMPARE1.635
WRITE(6,*)'WARNING LEN1=',LEN_EXTCNST1,' LEN2=',LEN_EXTCNST2 COMPARE1.636
ENDIF COMPARE1.637
JMIN=MIN0(LEN_EXTCNST1,LEN_EXTCNST2) COMPARE1.638
K=0 COMPARE1.639
DO I=1,JMIN COMPARE1.640
*IF DEF,T3E GAV0F405.48
IF(XOR(EXTCNST1(I),EXTCNST2(I)).NE.0) THEN GAV0F405.49
*ELSE GAV0F405.50
IF(EXTCNST1(I).NE.EXTCNST2(I))THEN GAV0F405.51
*ENDIF GAV0F405.52
K=K+1 COMPARE1.642
WRITE(6,*)'ITEM=',I,EXTCNST1(I),EXTCNST2(I) COMPARE1.643
ENDIF COMPARE1.644
ENDDO COMPARE1.645
UDG2F405.148
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.149
WRITE(8,*) 'EXTRA CONSTANTS: ', UDG2F405.150
& 'Number of differences = ',K UDG2F405.151
UDG2F405.152
L=L+K COMPARE1.647
ENDIF COMPARE1.648
ELSE UDR2F304.49
WRITE(6,*)'No comparison done' UDR2F304.50
IF (FIXHD1(130).LE.0) WRITE(6,*)'No array in FILE 1' UDR2F304.51
IF (FIXHD2(130).LE.0) WRITE(6,*)'No array in FILE 2' UDR2F304.52
ENDIF UDR2F304.53
COMPARE1.649
CL 11. Compare dump history COMPARE1.650
COMPARE1.651
WRITE(6,*)' ' UDR2F304.54
WRITE(6,*)'HISTORY BLOCK:' UDR2F304.55
IF(FIXHD1(135).GT.0 .AND. FIXHD2(135).GT.0) THEN UDR2F304.56
IF(LEN_DUMPHIST1.GT.0.OR.LEN_DUMPHIST2.GT.0)THEN COMPARE1.652
IF(LEN_DUMPHIST1.NE.LEN_DUMPHIST2)THEN COMPARE1.655
WRITE(6,*)'WARNING LEN1=',LEN_DUMPHIST1,' LEN2=',LEN_DUMPHIST2 COMPARE1.656
ENDIF COMPARE1.657
JMIN=MIN0(LEN_DUMPHIST1,LEN_DUMPHIST2) COMPARE1.658
K=0 COMPARE1.659
DO I=1,JMIN COMPARE1.660
*IF DEF,T3E GAV0F405.53
IF(XOR(DUMPHIST1(I),DUMPHIST2(I)).NE.0) THEN GAV0F405.54
*ELSE GAV0F405.55
IF(DUMPHIST1(I).NE.DUMPHIST2(I))THEN GAV0F405.56
*ENDIF GAV0F405.57
K=K+1 COMPARE1.662
WRITE(6,*)'ITEM=',I,DUMPHIST1(I),DUMPHIST2(I) COMPARE1.663
ENDIF COMPARE1.664
ENDDO COMPARE1.665
UDG2F405.153
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.154
WRITE(8,*) 'HISTORY BLOCK: ', UDG2F405.155
& 'Number of differences = ',K UDG2F405.156
L=L+K COMPARE1.667
ENDIF COMPARE1.668
ELSE UDR2F304.57
WRITE(6,*)'No comparison done' UDR2F304.58
IF (FIXHD1(135).LE.0) WRITE(6,*)'No array in FILE 1' UDR2F304.59
IF (FIXHD2(135).LE.0) WRITE(6,*)'No array in FILE 2' UDR2F304.60
ENDIF UDR2F304.61
COMPARE1.669
CL 12. Compare compressed index 1 COMPARE1.670
COMPARE1.671
WRITE(6,*)' ' UDR2F304.62
WRITE(6,*)'COMPRESSED INDEX 1:' UDR2F304.63
IF(FIXHD1(140).GT.0 .AND. FIXHD2(140).GT.0) THEN UDR2F304.64
IF(LEN_CFI11.GT.0.OR.LEN_CFI12.GT.0)THEN COMPARE1.672
IF(LEN_CFI11.NE.LEN_CFI12)THEN COMPARE1.675
WRITE(6,*)'WARNING LEN1=',LEN_CFI11,' LEN2=',LEN_CFI12 COMPARE1.676
ENDIF COMPARE1.677
JMIN=MIN0(LEN_CFI11,LEN_CFI12) COMPARE1.678
K=0 COMPARE1.679
DO I=1,JMIN COMPARE1.680
*IF DEF,T3E GAV0F405.58
IF(XOR(CFI11(I),CFI12(I)).NE.0) THEN GAV0F405.59
*ELSE GAV0F405.60
IF(CFI11(I).NE.CFI12(I))THEN GAV0F405.61
*ENDIF GAV0F405.62
K=K+1 COMPARE1.682
WRITE(6,*)'ITEM=',I,CFI11(I),CFI12(I) COMPARE1.683
ENDIF COMPARE1.684
ENDDO COMPARE1.685
UDG2F405.157
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.158
WRITE(8,*) 'COMPRESSED INDEX 1: ', UDG2F405.159
& 'Number of differences = ',K UDG2F405.160
L=L+K COMPARE1.687
ENDIF COMPARE1.688
ELSE UDR2F304.65
WRITE(6,*)'No comparison done' UDR2F304.66
IF (FIXHD1(140).LE.0) WRITE(6,*)'No array in FILE 1' UDR2F304.67
IF (FIXHD2(140).LE.0) WRITE(6,*)'No array in FILE 2' UDR2F304.68
ENDIF UDR2F304.69
COMPARE1.689
CL 13. Compare compressed index 2 COMPARE1.690
COMPARE1.691
WRITE(6,*)' ' UDR2F304.70
WRITE(6,*)'COMPRESSED INDEX 2:' UDR2F304.71
IF(FIXHD1(142).GT.0 .AND. FIXHD2(142).GT.0) THEN UDR2F304.72
IF(LEN_CFI21.GT.0.OR.LEN_CFI22.GT.0)THEN COMPARE1.692
IF(LEN_CFI21.NE.LEN_CFI22)THEN COMPARE1.695
WRITE(6,*)'WARNING LEN1=',LEN_CFI21,' LEN2=',LEN_CFI22 COMPARE1.696
ENDIF COMPARE1.697
JMIN=MIN0(LEN_CFI21,LEN_CFI22) COMPARE1.698
K=0 COMPARE1.699
DO I=1,JMIN COMPARE1.700
*IF DEF,T3E GAV0F405.63
IF(XOR(CFI21(I),CFI22(I)).NE.0) THEN GAV0F405.64
*ELSE GAV0F405.65
IF(CFI21(I).NE.CFI22(I))THEN GAV0F405.66
*ENDIF GAV0F405.67
K=K+1 COMPARE1.702
WRITE(6,*)'ITEM=',I,CFI21(I),CFI22(I) COMPARE1.703
ENDIF COMPARE1.704
ENDDO COMPARE1.705
UDG2F405.161
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.162
WRITE(8,*) 'COMPRESSED INDEX 2: ', UDG2F405.163
& 'Number of differences = ',K UDG2F405.164
L=L+K COMPARE1.707
ENDIF COMPARE1.708
ELSE UDR2F304.73
WRITE(6,*)'No comparison done' UDR2F304.74
IF (FIXHD1(142).LE.0) WRITE(6,*)'No array in FILE 1' UDR2F304.75
IF (FIXHD2(142).LE.0) WRITE(6,*)'No array in FILE 2' UDR2F304.76
ENDIF UDR2F304.77
COMPARE1.709
CL 14. Compare compressed index 3 COMPARE1.710
COMPARE1.711
WRITE(6,*)' ' UDR2F304.78
WRITE(6,*)'COMPRESSED INDEX 3:' UDR2F304.79
IF(FIXHD1(144).GT.0 .AND. FIXHD2(144).GT.0) THEN UDR2F304.80
IF(LEN_CFI31.GT.0.OR.LEN_CFI32.GT.0)THEN COMPARE1.712
IF(LEN_CFI31.NE.LEN_CFI32)THEN COMPARE1.715
WRITE(6,*)'WARNING LEN1=',LEN_CFI31,' LEN2=',LEN_CFI32 COMPARE1.716
ENDIF COMPARE1.717
JMIN=MIN0(LEN_CFI31,LEN_CFI32) COMPARE1.718
K=0 COMPARE1.719
DO I=1,JMIN COMPARE1.720
*IF DEF,T3E GAV0F405.68
IF(XOR(CFI31(I),CFI32(I)).NE.0) THEN GAV0F405.69
*ELSE GAV0F405.70
IF(CFI31(I).NE.CFI32(I))THEN GAV0F405.71
*ENDIF GAV0F405.72
K=K+1 COMPARE1.722
WRITE(6,*)'ITEM=',I,CFI31(I),CFI32(I) COMPARE1.723
ENDIF COMPARE1.724
ENDDO COMPARE1.725
UDG2F405.165
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.166
WRITE(8,*) 'COMPRESSED INDEX 3: ', UDG2F405.167
& 'Number of differences = ',K UDG2F405.168
L=L+K COMPARE1.727
ENDIF UDR2F304.81
ELSE UDR2F304.82
WRITE(6,*)'No comparison done' UDR2F304.83
IF (FIXHD1(144).LE.0) WRITE(6,*)'No array in FILE 1' UDR2F304.84
IF (FIXHD2(144).LE.0) WRITE(6,*)'No array in FILE 2' UDR2F304.85
ENDIF COMPARE1.728
COMPARE1.729
CL 15. Compare lookup tables COMPARE1.730
COMPARE1.731
IF(LEN1_LOOKUP1.NE.LEN1_LOOKUP2)THEN COMPARE1.732
WRITE(6,*)'ERROR first dimensions of lookup tables different' DR221193.26
WRITE(6,*)'LEN1=',LEN1_LOOKUP1,' LEN2=',LEN1_LOOKUP2 COMPARE1.734
CALL ABORT COMPARE1.735
ENDIF COMPARE1.736
IF(LEN2_LOOKUP1.GT.0.OR.LEN2_LOOKUP2.GT.0)THEN UDG2F405.169
WRITE(6,*)' ' UDG2F405.170
WRITE(6,*)'LOOKUP:' UDG2F405.171
UDG2F405.172
! Check length of lookup tables UDG2F405.173
IF(FIXHD1(5).EQ.3)THEN UDG2F405.174
DO I=1,LEN2_LOOKUP1 UDG2F405.175
IF(LOOKUP1(1,I).NE.-99)NUMREC1=I UDG2F405.176
END DO UDG2F405.177
DO I=1,LEN2_LOOKUP2 UDG2F405.178
IF(LOOKUP2(1,I).NE.-99)NUMREC2=I UDG2F405.179
END DO UDG2F405.180
ELSE UDG2F405.181
NUMREC1=LEN2_LOOKUP1 UDG2F405.182
NUMREC2=LEN2_LOOKUP2 UDG2F405.183
END IF UDG2F405.184
UDG2F405.185
IF(LEN2_LOOKUP1.NE.LEN2_LOOKUP2)THEN UDG2F405.186
WRITE(6,'(''WARNING LEN1 = '',i9,'' and LEN2 = '',i9)') PXCOMP.5
& len2_lookup1, len2_lookup2 UDG2F405.188
IF(FIXHD1(5).EQ.3)THEN UDG2F405.189
WRITE(6,'(''Fieldsfile file1 contains '',i5,'' fields '', UDG2F405.190
& ''and '',I5,'' empty records'')') UDG2F405.191
& NUMREC1,LEN2_LOOKUP1-NUMREC1 UDG2F405.192
WRITE(7,'(''Fieldsfile file1 contains '',i5,'' fields '', UDG2F405.193
& ''and '',I5,'' empty records'')') UDG2F405.194
& NUMREC1,LEN2_LOOKUP1-NUMREC1 UDG2F405.195
WRITE(6,'(''Fieldsfile file2 contains '',i5,'' fields '', UDG2F405.196
& ''and '',I5,'' empty records'')') UDG2F405.197
& NUMREC2,LEN2_LOOKUP2-NUMREC2 UDG2F405.198
WRITE(7,'(''Fieldsfile file2 contains '',i5,'' fields '', UDG2F405.199
& ''and '',I5,'' empty records'')') UDG2F405.200
& NUMREC2,LEN2_LOOKUP2-NUMREC2 UDG2F405.201
IF( NUMREC1.EQ.NUMREC2)THEN UDG2F405.202
WRITE(6,*) 'Files contain same number of fields' UDG2F405.203
WRITE(7,*) 'Files contain same number of fields' UDG2F405.204
IF(LEN2_LOOKUP1.EQ.NUMREC1)THEN UDG2F405.205
WRITE(6,*) 'Empty records at the end of file1 ', UDG2F405.206
& 'have probably been removed by convieee' UDG2F405.207
WRITE(7,*) 'Empty records at the end of file1 ', UDG2F405.208
& 'have probably been removed by convieee' UDG2F405.209
ELSE IF(LEN2_LOOKUP2.EQ.NUMREC2)THEN UDG2F405.210
WRITE(6,*) 'Empty records at the end of file2 ', UDG2F405.211
& 'have probably been removed by convieee' UDG2F405.212
WRITE(7,*) 'Empty records at the end of file2 ', UDG2F405.213
& 'have probably been removed by convieee' UDG2F405.214
END IF UDG2F405.215
END IF UDG2F405.216
END IF UDG2F405.217
END IF UDG2F405.218
UDG2F405.219
! Build cross reference index UDG2F405.220
OFFSET1=0 UDG2F405.221
OFFSET2=0 UDG2F405.222
DO I=1,LEN2_LOOKUP1 UDG2F405.223
INDEX(I) = 0 UDG2F405.224
LMISSING1(I) = .TRUE. UDG2F405.225
END DO UDG2F405.226
DO I=1,LEN2_LOOKUP2 UDG2F405.227
LMISSING2(I) = .TRUE. UDG2F405.228
END DO UDG2F405.229
DO I=1,NUMREC1 UDG2F405.230
N1=I+OFFSET1 UDG2F405.231
N2=I+OFFSET2 UDG2F405.232
IF(LOOKUP1(ITEM_CODE,N1).EQ.LOOKUP2(ITEM_CODE,N2))THEN UDG2F405.233
INDEX(I) = N2 UDG2F405.234
LMISSING1(I) = .FALSE. UDG2F405.235
LMISSING2(N2) = .FALSE. UDG2F405.236
ELSE UDG2F405.237
DO J=N2+1,NUMREC2 UDG2F405.238
IF(INDEX(I).EQ.0)THEN UDG2F405.239
IF(LOOKUP1(ITEM_CODE,N1).EQ. UDG2F405.240
& LOOKUP2(ITEM_CODE,J))THEN UDG2F405.241
OFFSET2 = OFFSET2+J-N2 UDG2F405.242
INDEX(I) = J UDG2F405.243
LMISSING1(I) = .FALSE. UDG2F405.244
LMISSING2(J) = .FALSE. UDG2F405.245
END IF UDG2F405.246
END IF UDG2F405.247
END DO UDG2F405.248
IF(INDEX(I).EQ.0)THEN UDG2F405.249
OFFSET2=OFFSET2-1 UDG2F405.250
END IF UDG2F405.251
END IF UDG2F405.252
END DO UDG2F405.253
UDG2F405.254
NMISSING1=0 UDG2F405.255
DO I=1,LEN2_LOOKUP1 UDG2F405.256
IF(LMISSING1(I).AND.LOOKUP1(1,I).NE.-99)THEN UDG2F405.257
NMISSING1=NMISSING1+1 UDG2F405.258
WRITE(6,'(''WARNING: Field '',I5,'' of file1 '', UDG2F405.259
& ''has no match in file2'')') I UDG2F405.260
END IF UDG2F405.261
END DO UDG2F405.262
NMISSING2=0 UDG2F405.263
DO I=1,LEN2_LOOKUP2 UDG2F405.264
IF(LMISSING2(I).AND.LOOKUP2(1,I).NE.-99)THEN UDG2F405.265
NMISSING2=NMISSING2+1 UDG2F405.266
WRITE(6,'(''WARNING: Field '',I5,'' of file2 '', UDG2F405.267
& ''has no match in file1'')') I UDG2F405.268
END IF UDG2F405.269
END DO UDG2F405.270
UDG2F405.271
K=0 UDG2F405.272
DO I=1,NUMREC1 UDG2F405.273
IF(.NOT.LMISSING1(I).AND.LOOKUP1(1,I).NE.-99)THEN UDG2F405.274
DO J=1,LEN1_LOOKUP1 UDG2F405.275
IF(LOOKUP1(J,I).NE.LOOKUP2(J,INDEX(I)))THEN UDG2F405.276
K=K+1 UDG2F405.277
ID1=LOOKUP1(J,I) UDG2F405.278
ID2=LOOKUP2(J,INDEX(I)) UDG2F405.279
IF (J.GE.46 .AND. J.LE.64) THEN UDG2F405.280
WRITE(6,'(''Header1: '',I5,'' Header2: '',I5, UDG2F405.281
& '' Item: '',I3,'' Values: '',F12.5,F12.5)') UDG2F405.282
& I,INDEX(I),J,RD1,RD2 UDG2F405.283
ELSE UDG2F405.284
WRITE(6,'(''Header1: '',I5,'' Header2: '',I5, UDG2F405.285
& '' Item: '',I3,'' Values: '',I8,I8)') UDG2F405.286
& I,INDEX(I),J,ID1,ID2 UDG2F405.287
END IF UDG2F405.288
END IF UDG2F405.289
END DO UDG2F405.290
END IF UDG2F405.291
END DO UDG2F405.292
UDG2F405.293
IF(K.EQ.0) WRITE(6,*) 'OK' UDG2F405.294
WRITE(7,'(''Number of fields in file 1 = '',I5)') NUMREC1 UDG2F405.295
WRITE(7,'(''Number of fields in file 2 = '',I5)') NUMREC2 UDG2F405.296
WRITE(7,'(''Number of fields compared = '',I5)') UDG2F405.297
& NUMREC1-NMISSING1 UDG2F405.298
IF(NMISSING1.NE.0)THEN UDG2F405.299
WRITE(7,'(''Number of fields from file 1 omitted from '', UDG2F405.300
& ''comparison = '',I5)') NMISSING1 UDG2F405.301
END IF UDG2F405.302
IF(NMISSING2.NE.0)THEN UDG2F405.303
WRITE(7,'(''Number of fields from file 2 omitted from '', UDG2F405.304
& ''comparison = '',I5)') NMISSING2 UDG2F405.305
END IF UDG2F405.306
WRITE(8,*) 'LOOKUP: ', UDG2F405.307
& 'Number of differences = ',K UDG2F405.308
L=L+K UDG2F405.309
END IF UDG2F405.310
COMPARE1.757
CL 16. Compare data fields COMPARE1.758
COMPARE1.759
DR221193.34
WRITE(6,*)' ' COMPARE1.760
WRITE(6,*)'DATA FIELDS:' COMPARE1.761
DR221193.35
M=0 UDG2F405.311
N=0 UDG2F405.312
DO I=1,NUMREC1 ! Begin loop over number of fields in file1 UDG2F405.313
UDG2F405.314
S_ITEM_CODE=MOD(LOOKUP1(42,I),1000) UDG2F405.315
SECTION=(LOOKUP1(42,I)-S_ITEM_CODE)/1000 UDG2F405.316
IF(FIXHD1(12).GE.305)THEN UDG2F405.317
MODEL=LOOKUP1(45,I) UDG2F405.318
ELSEIF(S_ITEM_CODE.LE.100.OR. UDG2F405.319
& (S_ITEM_CODE.GE.200.AND.S_ITEM_CODE.LE.205))THEN UDG2F405.320
MODEL=1 UDG2F405.321
ELSEIF((S_ITEM_CODE.GT.100.AND.S_ITEM_CODE.LE.176).OR. UDG2F405.322
& (S_ITEM_CODE.GE.180.AND.S_ITEM_CODE.LE.200))THEN UDG2F405.323
MODEL=2 UDG2F405.324
ELSEIF((S_ITEM_CODE.GE.177.AND.S_ITEM_CODE.LE.179).OR. UDG2F405.325
& (S_ITEM_CODE.GE.210.AND.S_ITEM_CODE.LE.212))THEN UDG2F405.326
MODEL=3 UDG2F405.327
END IF UDG2F405.328
UDG2F405.329
PHRASE=EXPPXC(MODEL,SECTION,S_ITEM_CODE, UDG2F405.330
*CALL ARGPPX UDG2F405.331
& ICODE,CMESSAGE) UDG2F405.332
IF(ICODE.NE.0)THEN UDG2F405.333
WRITE(6,*) CMESSAGE UDG2F405.334
PHRASE='NON-STANDARD FIELD' UDG2F405.335
END IF UDG2F405.336
UDG2F405.337
IF(.NOT.LMISSING1(I))THEN UDG2F405.338
M=INDEX(I) UDG2F405.339
DR221193.43
IF((LOOKUP1(42,I).EQ.28.OR.LOOKUP1(42,I).EQ.29).AND. UDG1F400.7
& (FIXHD1(12).NE.FIXHD2(12).AND. UDG1F400.8
& (FIXHD1(12).GE.400.OR.FIXHD2(12).GE.400)))THEN UDG1F400.9
LEN_FIELD=MIN0(LOOKUP1(15,I),LOOKUP2(15,M)) UDG2F405.340
ELSE UDG1F400.11
LEN_FIELD=LOOKUP1(15,I) UDG1F400.12
END IF UDG1F400.13
IF(FIXHD1(12).LT.0.AND.FIXHD1(5).NE.3)LOOKUP1(30,I)=0 UDG2F405.341
IF(FIXHD2(12).LT.0.AND.FIXHD2(5).NE.3)LOOKUP2(30,M)=0 UDG2F405.342
IF (LOOKUP1(1,I).NE.-99 .AND. LOOKUP2(1,M).NE.-99) THEN UDG2F405.343
DR221193.45
PACK_CODE1 = MOD(LOOKUP1(21,I),10) DR221193.46
PACK_CODE2 = MOD(LOOKUP2(21,I),10) PXCOMP.6
DR221193.48
lblrec_1=lookup1(15, i) UBC3F402.70
lblrec_2=lookup2(15, i) UBC3F402.71
UBC3F402.72
if ((pack_code1.eq.1 .or. pack_code2.eq.1) .and. UBC3F402.73
& wgdos_expand.ne.1) then UBC3F402.74
DR221193.53
ELSEIF (PACK_CODE1.EQ.3 .OR. PACK_CODE2.EQ.3) THEN DR221193.54
DR221193.55
WRITE(6,*) DR221193.56
& 'Field No ',I,' not compared. GRIB data not supported.' DR221193.57
DR221193.58
ELSE DR221193.59
COMPARE1.772
IF((LOOKUP1(39,I).EQ. 1 .AND. LOOKUP2(39,M).EQ. 1).OR. UDG2F405.345
& (LOOKUP1(39,I).EQ.-1 .AND. LOOKUP2(39,M).EQ.-1))THEN UDG2F405.346
! This is a REAL field GPB2F401.36
CALL READFLDS(NFTIN1,1,I,LOOKUP1,LEN1_LOOKUP1, GPB2F401.37
& R_D1,MAX_FIELD_SIZE1,FIXHD1, GPB2F401.38
*CALL ARGPPX GPB2F401.39
& wgdos_expand,icode,cmessage) UBC3F402.75
IF(ICODE.NE.0)CALL ABORT_IO('COMPARE',CMESSAGE,ICODE,NFTIN1) GPB2F401.41
GPB2F401.42
CALL READFLDS(NFTIN2,1,M,LOOKUP2,LEN1_LOOKUP2, UDG2F405.347
& R_D2,MAX_FIELD_SIZE2,FIXHD2, GPB2F401.44
*CALL ARGPPX GPB2F401.45
& wgdos_expand,icode,cmessage) UBC3F402.76
IF(ICODE.NE.0)CALL ABORT_IO('COMPARE',CMESSAGE,ICODE,NFTIN1) GPB2F401.47
GPB2F401.48
ELSE IF((LOOKUP1(39,I).EQ. 2 .AND. LOOKUP2(39,M).EQ. 2).OR. UDG2F405.348
& (LOOKUP1(39,I).EQ.-2 .AND. LOOKUP2(39,M).EQ.-2))THEN UDG2F405.349
! This is an INTEGER field GPB2F401.53
CALL READFLDS(NFTIN1,1,I,LOOKUP1,LEN1_LOOKUP1, GPB2F401.54
& I_D1,MAX_FIELD_SIZE1,FIXHD1, GPB2F401.55
*CALL ARGPPX GPB2F401.56
& wgdos_expand,icode,cmessage) UBC3F402.77
IF(ICODE.NE.0)CALL ABORT_IO('COMPARE',CMESSAGE,ICODE,NFTIN1) GPB2F401.58
GPB2F401.59
CALL READFLDS(NFTIN2,1,M,LOOKUP2,LEN1_LOOKUP2, UDG2F405.350
& I_D2,MAX_FIELD_SIZE2,FIXHD2, GPB2F401.61
*CALL ARGPPX GPB2F401.62
& wgdos_expand,icode,cmessage) UBC3F402.78
IF(ICODE.NE.0)CALL ABORT_IO('COMPARE',CMESSAGE,ICODE,NFTIN1) GPB2F401.64
GPB2F401.65
ELSE IF((LOOKUP1(39,I).EQ. 3 .AND. LOOKUP2(39,M).EQ. 3).OR. UDG2F405.351
& (LOOKUP1(39,I).EQ.-3 .AND. LOOKUP2(39,M).EQ.-3))THEN UDG2F405.352
! This is an LOGICAL field GPB2F401.70
CALL READFLDS(NFTIN1,1,I,LOOKUP1,LEN1_LOOKUP1, GPB2F401.71
& L_D1,MAX_FIELD_SIZE1,FIXHD1, GPB2F401.72
*CALL ARGPPX GPB2F401.73
& wgdos_expand,icode,cmessage) UBC3F402.79
IF(ICODE.NE.0)CALL ABORT_IO('COMPARE',CMESSAGE,ICODE,NFTIN1) GPB2F401.75
GPB2F401.76
CALL READFLDS(NFTIN2,1,M,LOOKUP2,LEN1_LOOKUP2, UDG2F405.353
& L_D2,MAX_FIELD_SIZE2,FIXHD2, GPB2F401.78
*CALL ARGPPX GPB2F401.79
& wgdos_expand,icode,cmessage) UBC3F402.80
IF(ICODE.NE.0)CALL ABORT_IO('COMPARE',CMESSAGE,ICODE,NFTIN1) GPB2F401.81
GPB2F401.82
ELSE GPB2F401.83
! This is an unrecognized field GPB2F401.84
WRITE(6,*) UDG2F402.27
& 'Field No ',I,' not compared. Unrecognized type.' UDG2F402.28
GPB2F401.87
ENDIF GPB2F401.88
if ((pack_code1.eq.1 .or. pack_code2.eq.1) .and. UDG1F403.14
& wgdos_expand.eq.1) then UDG1F403.15
LEN_FIELD=LOOKUP1(15,I) UDG1F403.16
endif UDG1F403.17
lookup1(15, i)=lblrec_1 UBC3F402.81
lookup2(15, M)=lblrec_2 UDG2F405.354
UDG2F405.355
COMPARE1.796
WRITE(6,*)' ' COMPARE1.797
WRITE(6,*)LOOKUP1(42,I),': ',PHRASE,':' COMPARE1.798
write(10,'(/''Field '',i5,'' : Stash Code '',i5, UDG2F402.29
& '' : '',a)') i, lookup1(42,i), phrase UDG2F402.30
GPB2F401.91
RMS_F1=0.0 GPB2F401.92
RMS_F2=0.0 GPB2F401.93
RMS_DIFF=0.0 GPB2F401.94
K=0 COMPARE1.799
*IF DEF,T3E GBC7F404.143
jrc_nan=0 UDG2F402.31
*ENDIF GBC7F404.144
C Real DR221193.60
IF (LOOKUP1(39,I).EQ.1 .AND. LOOKUP2(39,M).EQ.1) THEN UDG2F405.356
MAX_DIFF=0. DR221193.62
DO J=1,LEN_FIELD UDG1F400.14
DIFF(J)='.' GPB2F401.95
*IF DEF,T3E GAV0F405.73
IF(XOR(R_D1(J),R_D2(J)).NE.0) THEN GAV0F405.74
*ELSE GAV0F405.75
IF(R_D1(J).NE.R_D2(J))THEN GAV0F405.76
*ENDIF GAV0F405.77
k=k+1 UDG2F402.33
if(k.le.10) then UDG2F402.34
write(6,'(a,i6,2(e25.15,'' ('',z16,'')''))') UDG2F402.35
& 'ITEM=',j,r_d1(j),r_d1(j),r_d2(j),r_d2(j) UDG2F402.36
endif UDG2F402.37
*IF DEF,T3E GBC7F404.145
if((xor(and(r_d1(j),jrc_mask),jrc_mask).ne.0) .and. UDG2F402.38
& (xor(and(r_d2(j),jrc_mask),jrc_mask).ne.0) .and. UDG2F402.39
& (and(r_d1(j),deb_mask).ne.0.or. UDG2F402.40
& xor(r_d1(j),0).eq.0).and. UDG2F402.41
& (and(r_d2(j),deb_mask).ne.0.or. UDG2F402.42
& xor(r_d2(j),0).eq.0))then UDG2F402.43
*ENDIF GBC7F404.146
RD1=R_D1(J) UDG2F402.44
RD2=R_D2(J) UDG2F402.45
MAX_DIFF=MAX(MAX_DIFF,ABS(RD1-RD2)) UDG2F402.46
IF(MAX_DIFF.EQ.ABS(RD1-RD2)) MAX_J = J UDG1F403.25
if(rd1.eq.0.) then UDG2F402.47
if(rd2.eq.0.) then UDG2F402.48
diff_per=0. UDG2F402.49
else UDG2F402.50
diff_per=(abs(rd1-rd2)/abs(rd2))*100 UDG2F402.51
endif UDG2F402.52
else UDG2F402.53
diff_per=(abs(rd1-rd2)/abs(rd1))*100 UDG2F402.54
endif UDG2F402.55
IF (DIFF_PER .GT. 10.0) DIFF(J)="#" GPB2F401.111
IF (DIFF_PER .LT. 10.0) DIFF(J)="X" GPB2F401.112
IF (DIFF_PER .LT. 1.0) DIFF(J)="O" GPB2F401.113
IF (DIFF_PER .LT. 0.1) DIFF(J)="o" GPB2F401.114
IF (DIFF_PER .LT. 0.01) DIFF(J)=":" GPB2F401.115
RMS_F1=RMS_F1+(R_D1(J)*R_D1(J)) UDG2F402.56
RMS_F2=RMS_F2+(R_D2(J)*R_D2(J)) UDG2F402.57
RMS_DIFF=RMS_DIFF+(R_D1(J)-R_D2(J))*(R_D1(J)-R_D2(J)) UDG2F402.58
*IF DEF,T3E GBC7F404.147
else UDG2F402.59
jrc_nan=jrc_nan+1 UDG2F402.60
endif UDG2F402.61
*ENDIF GBC7F404.148
else UDG2F402.62
*IF DEF,T3E GBC7F404.149
if((xor(and(r_d1(j),jrc_mask),jrc_mask).ne.0) .and. UDG2F402.63
& (xor(and(r_d2(j),jrc_mask),jrc_mask).ne.0) .and. UDG2F402.64
& (and(r_d1(j),deb_mask).ne.0.or. UDG2F402.65
& xor(r_d1(j),0).eq.0).and. UDG2F402.66
& (and(r_d2(j),deb_mask).ne.0.or. UDG2F402.67
& xor(r_d2(j),0).eq.0))then UDG2F402.68
*ENDIF GBC7F404.150
RMS_F1=RMS_F1+(R_D1(J)*R_D1(J)) UDG2F402.69
RMS_F2=RMS_F2+(R_D2(J)*R_D2(J)) UDG2F402.70
RMS_DIFF=RMS_DIFF+(R_D1(J)-R_D2(J))*(R_D1(J)-R_D2(J)) UDG2F402.71
*IF DEF,T3E GBC7F404.151
else UDG2F402.72
jrc_nan=jrc_nan+1 UDG2F402.73
endif UDG2F402.74
*ENDIF GBC7F404.152
endif UDG2F402.75
ENDDO DR221193.69
IF (K.NE.0) THEN DR221193.70
WRITE(6,*)'NUMBER OF DIFFERENT VALUES = ',K DR221193.71
WRITE(6,*)'MAXIMUM DIFFERENCE= ',MAX_DIFF,' AT PT. ',MAX_J UDG1F403.22
RMS_F1=SQRT(RMS_F1/LEN_FIELD) UDG1F403.18
RMS_F2=SQRT(RMS_F2/LEN_FIELD) UDG1F403.19
RMS_DIFF=SQRT(RMS_DIFF/LEN_FIELD) UDG1F403.20
WRITE(6,*) 'RMS FIELD1 : ',RMS_F1 GPB2F401.120
WRITE(6,*) 'RMS FIELD2 : ',RMS_F2 GPB2F401.121
DIFF_PER=ABS(RMS_F1-RMS_F2) GPB2F401.122
WRITE(6,*) 'Difference: ',DIFF_PER GPB2F401.123
& ,' RMS_difference: ',RMS_DIFF UDG9F404.100
rd1=diff_per UDG2F402.76
if(rms_f1.ne.0.) then UDG2F402.77
diff_per=(diff_per/rms_f1)*100 UDG2F402.78
write(6,'(''Field '',i5,'' has a Difference between'', UDG2F402.79
& '' the RMS Values of '',e10.5,'' which is '',f10.3, UDG2F402.80
& '' Percent of Field 1, whose RMS Value is '',e10.5)') UDG2F402.81
& i, rd1, diff_per, rms_f1 UDG2F402.82
write(6,*) 'Difference as % of RMS FIELD1= ',DIFF_PER UDG2F402.83
else if(rms_f2.ne.0.) then UDG2F402.84
diff_per=(diff_per/rms_f2)*100 UDG2F402.85
write(6,'(''Field '',i5,'' has a Difference between'', UDG2F402.86
& '' the RMS Values of '',e10.5,'' which is '',f10.3, UDG2F402.87
& '' Percent of Field 2, whose RMS Value is '',e10.5)') UDG2F402.88
& i, rd1, diff_per, rms_f2 UDG2F402.89
write(6,*) 'Difference as % of RMS FIELD2= ',DIFF_PER UDG2F402.90
*IF DEF,T3E GBC7F404.153
else UDG2F402.91
if(jrc_nan.eq.0) write(6,'(''Field '',i5, UDG2F402.92
& '' - the Fields in Both Files have RMS Values of Zero'' UDG2F402.93
& )') i UDG2F402.94
*ENDIF GBC7F404.154
endif UDG2F402.95
c UDG2F402.96
*IF DEF,T3E GBC7F404.155
if (diff_per .gt. 5 .or. jrc_nan.ne.0) THEN UDG2F402.97
*ELSE GBC7F404.156
if (diff_per .gt. 5) THEN GBC7F404.157
*ENDIF GBC7F404.158
WRITE(6,*) GPB2F401.129
WRITE(6,*) GPB2F401.130
*IF DEF,T3E GBC7F404.159
if(jrc_nan.ne.0) then UDG2F402.98
write(6,*) '********** NaN Values Detected **********', UDG2F402.99
& '**' UDG2F402.100
endif UDG2F402.101
*ENDIF GBC7F404.160
WRITE(6,*) '************** WARNING ********************' GPB2F401.131
WRITE(6,*) '***** LARGE DIFFERENCE ENCOUNTERED ********' GPB2F401.132
WRITE(6,*) '*******************************************' GPB2F401.133
WRITE(6,*) GPB2F401.134
ENDIF GPB2F401.135
GPB2F401.136
KEY='# d>10% ; X 10%>d>1% ; O 1%>d>0.1% ; '// GPB2F401.137
& 'o 0.1%>d>0.01% ; : d<0.01% ; . d=0%' GPB2F401.138
GPB2F401.139
IF ( MOD(LOOKUP1(16,I),100) .LT. 21) THEN UDG1F403.34
! Only certain grid types are suitable for difference maps GPB2F401.141
CALL PRINT_DIF_MAP(DIFF,LOOKUP1(18,I),LOOKUP1(19,I),KEY) GPB2F401.142
ELSE UDG1F403.35
write(6,*) 'Difference map not printed' UDG1F403.36
write(6,*) 'Grid Type not suitable for difference maps' UDG1F403.37
write(6,*) 'Grid Type = ',LOOKUP1(16,I) UDG1F403.38
ENDIF GPB2F401.143
GPB2F401.144
ELSE DR221193.73
WRITE(6,*)'OK' DR221193.74
WRITE(10,*)'OK' GPB2F401.145
ENDIF COMPARE1.806
C Integer DR221193.75
ELSE IF (LOOKUP1(39,I).EQ.2 .AND. LOOKUP2(39,M).EQ.2) THEN UDG2F405.357
IMAX_DIFF=0 DR221193.77
DO J=1,LEN_FIELD UDG1F400.15
DIFF(J)='.' GPB2F401.146
*IF DEF,T3E GAV0F405.78
IF (XOR(I_D1(J),I_D2(J)).NE.0) THEN GAV0F405.79
*ELSE GAV0F405.80
IF(I_D1(J).NE.I_D2(J))THEN GAV0F405.81
*ENDIF GAV0F405.82
K=K+1 GPB2F401.148
if (k.le.n_diff) write(6,*)'item=',j,i_d1(j),i_d2(j) UDG2F402.103
*IF DEF,T3E GBC7F404.161
if((xor(and(r_d1(j),jrc_mask),jrc_mask).ne.0) .and. UDG2F402.104
& (xor(and(r_d2(j),jrc_mask),jrc_mask).ne.0)) then UDG2F402.105
*ENDIF GBC7F404.162
ID1=I_D1(J) UDG2F402.106
ID2=I_D2(J) UDG2F402.107
IMAX_DIFF=MAX(IMAX_DIFF,ABS(ID1-ID2)) UDG2F402.108
UDG2F402.109
IF (ID1 .EQ. 0) THEN UDG2F402.110
IF (ID1 .EQ. ID2) THEN UDG2F402.111
DIFF_PER=0.0 UDG2F402.112
ELSE UDG2F402.113
DIFF_PER=100.0 UDG2F402.114
ENDIF UDG2F402.115
ELSE UDG1F403.11
DIFF_PER=(REAL(ABS(ID1-ID2))/REAL(ABS(ID1)))*100.0 UDG2F402.116
ENDIF UDG2F402.117
IF (DIFF_PER .GT. 10.0) DIFF(J)="#" GPB2F401.159
IF (DIFF_PER .LT. 10.0) DIFF(J)="X" GPB2F401.160
IF (DIFF_PER .LT. 1.0) DIFF(J)="O" GPB2F401.161
IF (DIFF_PER .LT. 0.1) DIFF(J)="o" GPB2F401.162
IF (DIFF_PER .LT. 0.01) DIFF(J)=":" GPB2F401.163
*IF DEF,T3E GBC7F404.163
else UDG2F402.118
jrc_nan=jrc_nan+1 UDG2F402.119
endif UDG2F402.120
*ENDIF GBC7F404.164
ENDIF DR221193.85
ENDDO DR221193.86
IF (K.NE.0) THEN DR221193.87
write(6,'(''Field '',i5,'' has '',i5, UDG2F402.121
& '' INTEGER Differences'', UDG2F402.122
& '' with a Maximum Difference of '',i20)') i, k, imax_diff UDG2F402.123
WRITE(6,*)'NUMBER OF DIFFERENT VALUES = ',K DR221193.88
*IF DEF,T3E GBC7F404.165
& ,' (',jrc_nan,') NaN Values Detected)' UDG2F402.124
*ENDIF GBC7F404.166
WRITE(6,*)'MAXIMUM DIFFERENCE= ',IMAX_DIFF DR221193.89
KEY='# d>10% ; X 10%>d>1% ; O 1%>d>0.1% ; '// GPB2F401.164
& 'o 0.1%>d>0.01% ; : d<0.01% ; . d=0%' GPB2F401.165
GPB2F401.166
IF ( LOOKUP1(16,I) .LT. 21) THEN GPB2F401.167
! Only certain grid types are suitable for difference maps GPB2F401.168
CALL PRINT_DIF_MAP(DIFF,LOOKUP1(18,I),LOOKUP1(19,I),KEY) GPB2F401.169
ENDIF GPB2F401.170
GPB2F401.171
ELSE DR221193.90
write(6,'(''Field '',i5, UDG2F402.125
& '' has '',i5,'' INTEGER Differences'')') i, k UDG2F402.126
write (6,*) 'OK' UDG2F402.127
WRITE(6,*)'OK' DR221193.91
WRITE(10,*)'OK' GPB2F401.172
ENDIF DR221193.92
C Logical DR221193.93
ELSE IF (LOOKUP1(39,I).EQ.3 .AND. LOOKUP2(39,M).EQ.3) THEN UDG2F405.358
DO J=1,LEN_FIELD UDG1F400.16
DIFF(J)='.' GPB2F401.173
IF (L_D1(J).NEQV.L_D2(J)) THEN GPB2F401.174
K=K+1 GPB2F401.175
LD1=L_D1(J) GPB2F401.176
LD2=L_D2(J) GPB2F401.177
IF (K.LE.N_DIFF) WRITE(6,*)'ITEM=',J,LD1,LD2 GPB2F401.178
DIFF(J)="#" GPB2F401.179
ENDIF DR221193.101
ENDDO DR221193.102
IF (K.NE.0) THEN DR221193.103
write(6,'(''Field '',i5,'' has '',i5, UDG2F402.128
& '' LOGICAL Differences'')') i, k UDG2F402.129
WRITE(6,*)'NUMBER OF DIFFERENT VALUES = ',K DR221193.104
KEY='# Different values ; . identical' GPB2F401.180
GPB2F401.181
IF ( LOOKUP1(16,I) .LT. 21) THEN GPB2F401.182
! Only certain grid types are suitable for difference maps GPB2F401.183
CALL PRINT_DIF_MAP(DIFF,LOOKUP1(18,I),LOOKUP1(19,I),KEY) GPB2F401.184
ENDIF GPB2F401.185
ELSE DR221193.105
write(6,'(''Field '',i5,'' has '',i5, UDG2F402.130
& '' LOGICAL Differences'')') i, k UDG2F402.131
write (6,*) 'OK' UDG2F402.132
WRITE(6,*)'OK' DR221193.106
WRITE(10,*)'OK' GPB2F401.186
ENDIF DR221193.107
C Real Timeseries UDG9F304.4
ELSE IF (LOOKUP1(39,I).EQ.-1 .AND. LOOKUP2(39,M).EQ.-1) THEN UDG2F405.359
MAX_DIFF=0. UDG9F304.6
DO J=1,LEN_FIELD UDG1F400.17
*IF DEF,T3E GAV0F405.83
IF(XOR(R_D1(J),R_D2(J)).NE.0) THEN GAV0F405.84
*ELSE GAV0F405.85
IF(R_D1(J).NE.R_D2(J))THEN GAV0F405.86
*ENDIF GAV0F405.87
MAX_DIFF=AMAX1(MAX_DIFF,ABS(R_D1(J)-R_D2(J))) GPB2F401.188
K=K+1 UDG9F304.10
IF(K.LE.10)WRITE(6,*)'ITEM=',J,R_D1(J),R_D2(J) GPB2F401.189
ENDIF UDG9F304.12
ENDDO UDG9F304.13
IF (K.NE.0) THEN UDG9F304.14
WRITE(6,*)'NUMBER OF DIFFERENT VALUES = ',K UDG9F304.15
WRITE(6,*)'MAXIMUM DIFFERENCE= ',MAX_DIFF UDG9F304.16
ELSE UDG9F304.17
WRITE(6,*)'OK' UDG9F304.18
ENDIF UDG9F304.19
C Integer Timeseries UDG9F304.20
ELSE IF (LOOKUP1(39,I).EQ.-2 .AND. LOOKUP2(39,M).EQ.-2) THEN UDG2F405.360
IMAX_DIFF=0 UDG9F304.22
DO J=1,LEN_FIELD UDG1F400.18
IF (I_D1(J).NE.I_D2(J)) THEN GPB2F401.190
K=K+1 UDG9F304.25
ID1=I_D1(J) GPB2F401.191
ID2=I_D2(J) GPB2F401.192
IMAX_DIFF=MAX(IMAX_DIFF,IABS(ID1-ID2)) UDG9F304.28
IF (K.LE.N_DIFF) WRITE(6,*)'ITEM=',J,ID1,ID2 UDG9F304.29
ENDIF UDG9F304.30
ENDDO UDG9F304.31
IF (K.NE.0) THEN UDG9F304.32
WRITE(6,*)'NUMBER OF DIFFERENT VALUES = ',K UDG9F304.33
WRITE(6,*)'MAXIMUM DIFFERENCE= ',IMAX_DIFF UDG9F304.34
ELSE UDG9F304.35
WRITE(6,*)'OK' UDG9F304.36
ENDIF UDG9F304.37
C Logical Timeseries UDG9F304.38
ELSE IF (LOOKUP1(39,I).EQ.-3 .AND. LOOKUP2(39,M).EQ.-3) THEN UDG2F405.361
DO J=1,LEN_FIELD UDG1F400.19
IF (L_D1(J).NEQV.L_D2(J)) THEN GPB2F401.193
K=K+1 UDG9F304.42
LD1=L_D1(J) GPB2F401.194
LD2=L_D2(J) GPB2F401.195
IF (K.LE.N_DIFF) WRITE(6,*)'ITEM=',J,LD1,LD2 UDG9F304.45
ENDIF UDG9F304.46
ENDDO UDG9F304.47
IF (K.NE.0) THEN UDG9F304.48
WRITE(6,*)'NUMBER OF DIFFERENT VALUES = ',K UDG9F304.49
ELSE UDG9F304.50
WRITE(6,*)'OK' UDG9F304.51
ENDIF UDG9F304.52
ELSE COMPARE1.811
WRITE(6,*) DR221193.108
& 'Field No ',I,' not compared. Different Data Type Numbers ?' DR221193.109
ENDIF COMPARE1.813
WRITE(6,*)' ' DR221193.110
IF(K.NE.0)THEN UDG2F405.362
NDIFFER(I)=K UDG2F405.363
N=N+1 UDG2F405.364
END IF UDG2F405.365
L=L+K COMPARE1.814
END IF UDG2F405.366
COMPARE1.815
ENDIF DR221193.111
ENDIF DR221193.112
ENDDO !End loop over number of fields COMPARE1.816
DR221193.113
! Output remainder of summary information UDG2F405.367
WRITE(8,*) 'DATA FIELDS: ', UDG2F405.368
& 'Number of fields with differences = ',N UDG2F405.369
DO I = 1,NUMREC1 ! Begin loop over number of fields in file1 UDG2F405.370
IF(LOOKUP1(1,I).NE.-99)THEN UDG2F405.371
S_ITEM_CODE=MOD(LOOKUP1(42,I),1000) UDG2F405.372
SECTION=(LOOKUP1(42,I)-S_ITEM_CODE)/1000 UDG2F405.373
IF(FIXHD2(12).GE.305)THEN UDG2F405.374
MODEL=LOOKUP1(45,I) UDG2F405.375
ELSEIF(S_ITEM_CODE.LE.100.OR. UDG2F405.376
& (S_ITEM_CODE.GE.200.AND.S_ITEM_CODE.LE.205))THEN UDG2F405.377
MODEL=1 UDG2F405.378
ELSEIF((S_ITEM_CODE.GT.100.AND.S_ITEM_CODE.LE.176).OR. UDG2F405.379
& (S_ITEM_CODE.GE.180.AND.S_ITEM_CODE.LE.200))THEN UDG2F405.380
MODEL=2 UDG2F405.381
ELSEIF((S_ITEM_CODE.GE.177.AND.S_ITEM_CODE.LE.179).OR. UDG2F405.382
& (S_ITEM_CODE.GE.210.AND.S_ITEM_CODE.LE.212))THEN UDG2F405.383
MODEL=3 UDG2F405.384
END IF UDG2F405.385
UDG2F405.386
PHRASE=EXPPXC(MODEL,SECTION,S_ITEM_CODE, UDG2F405.387
*CALL ARGPPX UDG2F405.388
& ICODE,CMESSAGE) UDG2F405.389
IF(ICODE.NE.0)THEN UDG2F405.390
WRITE(6,*) CMESSAGE UDG2F405.391
PHRASE='NON-STANDARD FIELD' UDG2F405.392
END IF UDG2F405.393
IF(LMISSING1(I))THEN UDG2F405.394
WRITE(8,'(/''Field '',i5,'' : Stash Code '',i5,'' : '',a, UDG2F405.395
& '' : No equivalent in file2'')') UDG2F405.396
& I,LOOKUP1(42,I),PHRASE UDG2F405.397
ELSE IF(NDIFFER(I).NE.0)THEN UDG2F405.398
WRITE(8,'(/''Field '',I5,'' : Stash Code '',I5, UDG2F405.399
& '' : '',A,'' : Number of differences = '',I8)') UDG2F405.400
& I, LOOKUP1(42,I), PHRASE, NDIFFER(I) UDG2F405.401
END IF UDG2F405.402
END IF UDG2F405.403
END DO UDG2F405.404
DO I = 1,NUMREC2 ! Begin loop over number of fields in file2 UDG2F405.405
IF(LMISSING2(I).AND.LOOKUP2(1,I).NE.-99)THEN UDG2F405.406
S_ITEM_CODE=MOD(LOOKUP2(42,I),1000) UDG2F405.407
SECTION=(LOOKUP2(42,I)-S_ITEM_CODE)/1000 UDG2F405.408
IF(FIXHD2(12).GE.305)THEN UDG2F405.409
MODEL=LOOKUP2(45,I) UDG2F405.410
ELSEIF(S_ITEM_CODE.LE.100.OR. UDG2F405.411
& (S_ITEM_CODE.GE.200.AND.S_ITEM_CODE.LE.205))THEN UDG2F405.412
MODEL=1 UDG2F405.413
ELSEIF((S_ITEM_CODE.GT.100.AND.S_ITEM_CODE.LE.176).OR. UDG2F405.414
& (S_ITEM_CODE.GE.180.AND.S_ITEM_CODE.LE.200))THEN UDG2F405.415
MODEL=2 UDG2F405.416
ELSEIF((S_ITEM_CODE.GE.177.AND.S_ITEM_CODE.LE.179).OR. UDG2F405.417
& (S_ITEM_CODE.GE.210.AND.S_ITEM_CODE.LE.212))THEN UDG2F405.418
MODEL=3 UDG2F405.419
END IF UDG2F405.420
UDG2F405.421
PHRASE=EXPPXC(MODEL,SECTION,S_ITEM_CODE, UDG2F405.422
*CALL ARGPPX UDG2F405.423
& ICODE,CMESSAGE) UDG2F405.424
IF(ICODE.NE.0)THEN UDG2F405.425
WRITE(6,*) CMESSAGE UDG2F405.426
PHRASE='NON-STANDARD FIELD' UDG2F405.427
END IF UDG2F405.428
WRITE(8,'(/''Field '',i5,'' : Stash Code '',i5,'' : '',a, UDG2F405.429
& '' : No equivalent in file1'')') UDG2F405.430
& I,LOOKUP2(42,I),PHRASE UDG2F405.431
ENDIF UDG2F405.432
END DO UDG2F405.433
CLOSE(10) GPB2F401.196
IF(L.EQ.0)THEN UDG2F405.434
WRITE(8,*)' files compare (ignoring Fixed Length Header)' UDG2F405.435
ELSE COMPARE1.823
WRITE(8,*)' files DO NOT compare' UDG2F405.436
ENDIF COMPARE1.825
WRITE(7,*)' ' COMPARE1.826
CLOSE(7) GGH4F401.13
COMPARE1.827
RETURN COMPARE1.828
END COMPARE1.829
GPB2F401.197
SUBROUTINE PRINT_DIF_MAP(DIFF,ROWS,COLS,KEY) 3GPB2F401.198
!LL Writes out a map of the differences between two fields - with one GPB2F401.199
!LL character per point. This allows points in two fields which are GPB2F401.200
!LL different to be quickly identified. GPB2F401.201
!LL Writes to UNIT10 - opened in COMPARE - filename must be supplied GPB2F401.202
!LL by UNIT10 environment variable via the cumf script GPB2F401.203
GPB2F401.204
IMPLICIT NONE GPB2F401.205
GPB2F401.206
INTEGER GPB2F401.207
& ROWS ! IN : number of rows in field GPB2F401.208
&, COLS ! IN : number of cols in field GPB2F401.209
GPB2F401.210
CHARACTER*1 GPB2F401.211
& DIFF(ROWS*COLS) ! IN : difference map field to be output GPB2F401.212
GPB2F401.213
CHARACTER*(*) UDG2F402.134
& KEY ! IN : key to difference map GPB2F401.215
GPB2F401.216
! Local variables GPB2F401.217
INTEGER X,Y,Z GPB2F401.218
integer i ,j UDG2F402.135
UDG2F402.136
character*1 numb(10), blank UDG2F402.137
UDG2F402.138
data numb/'0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/ UDG2F402.139
data blank /' '/ UDG2F402.140
UDG2F402.141
WRITE(10,'(/a/)') KEY UDG2F402.142
GPB2F401.221
*IF DEF,LFOK GPB2F401.222
UDG2F402.143
write(10,'(6x,120a1)') ((blank, j=1,9), UDG2F402.144
2 numb(mod((i+10)/10, 10)+1), i=1, cols, 10) UDG2F402.145
c UDG2F402.146
write(10,'(6x,120a1)') (numb(mod(i, 10)+1), i=1,cols) UDG2F402.147
UDG2F402.148
do y=1,rows UDG2F402.149
z=(y-1)*cols UDG2F402.150
if(cols.eq.120) then UDG2F402.151
write(10,123) y,(diff(x+z),x=1,cols) UDG2F402.152
123 format(1x,i3,'->',120a1) UDG2F402.153
else UDG2F402.154
write(10,124) y,(diff(x+z),x=1,cols) UDG2F402.155
124 format(1x,i3,'->',120a1/(6x,120a1)) UDG2F402.156
endif UDG2F402.157
enddo UDG2F402.158
*ELSE GPB2F401.250
WRITE(6,*) 'Difference maps not supported on this platform' GPB2F401.251
*ENDIF GPB2F401.252
GPB2F401.253
RETURN GPB2F401.254
END GPB2F401.255
*ENDIF COMPARE1.830