SUBROUTINE READHEAD(NFTIN,FIXHD,LEN_FIXHD, ! Intent (In) 23,42GDG0F401.1232
& INTHD,LEN_INTHD, GDG0F401.1233
& REALHD,LEN_REALHD, GDG0F401.1234
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GDG0F401.1235
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GDG0F401.1236
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GDG0F401.1237
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GDG0F401.1238
& EXTCNST,LEN_EXTCNST, GDG0F401.1239
& DUMPHIST,LEN_DUMPHIST, GDG0F401.1240
& CFI1,LEN_CFI1, GDG0F401.1241
& CFI2,LEN_CFI2, GDG0F401.1242
& CFI3,LEN_CFI3, GDG0F401.1243
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA, GDG0F401.1244
*CALL ARGPPX 
GDG0F401.1245
& START_BLOCK,ICODE,CMESSAGE) ! Intent (Out) GDG0F401.1246
READHE1A.40
IMPLICIT NONE READHE1A.41
READHE1A.42
INTEGER READHE1A.43
* NFTIN !IN Unit no of dump READHE1A.44
*,LEN_FIXHD !IN Length of fixed length header READHE1A.45
*,LEN_INTHD !IN Length of integer header READHE1A.46
*,LEN_REALHD !IN Length of real header READHE1A.47
*,LEN1_LEVDEPC !IN 1st dim of level dep consts READHE1A.48
*,LEN2_LEVDEPC !IN 2ndt dim of level dep consts READHE1A.49
*,LEN1_ROWDEPC !IN 1st dim of row dep consts READHE1A.50
*,LEN2_ROWDEPC !IN 2nd dim of row dep consts READHE1A.51
&,LEN1_COLDEPC !IN 1st dim of column dep consts READHE1A.52
&,LEN2_COLDEPC !IN 2nd dim of column dep consts READHE1A.53
&,LEN1_FLDDEPC !IN 1st dim of field dep consts READHE1A.54
&,LEN2_FLDDEPC !IN 2nd dim of field dep consts READHE1A.55
&,LEN_EXTCNST !IN Length of extra constants READHE1A.56
&,LEN_DUMPHIST !IN Length of history block READHE1A.57
&,LEN_CFI1 !IN Length of comp field index 1 READHE1A.58
&,LEN_CFI2 !IN Length of comp field index 2 READHE1A.59
&,LEN_CFI3 !IN Length of comp field index 3 READHE1A.60
&,LEN1_LOOKUP !IN 1st dim of lookup READHE1A.61
&,LEN2_LOOKUP !IN 2nd dim of lookup READHE1A.62
READHE1A.63
INTEGER READHE1A.64
* LEN_DATA !IN Length of model data READHE1A.65
*,START_BLOCK !OUT Pointer to position of each block. READHE1A.66
* !Should point to start of model data block on exit READHE1A.67
*,ICODE !OUT Return code; successful=0 READHE1A.68
* ! error > 0 READHE1A.69
READHE1A.70
CHARACTER*(80) TS150793.155
* CMESSAGE !OUT Error message if ICODE > 0 READHE1A.72
READHE1A.73
INTEGER READHE1A.74
* FIXHD(LEN_FIXHD) !IN Fixed length header READHE1A.75
*,INTHD(LEN_INTHD) !IN Integer header READHE1A.76
*,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) !IN PP lookup tables READHE1A.77
*,CFI1(LEN_CFI1+1) !IN Compressed field index no 1 READHE1A.78
*,CFI2(LEN_CFI2+1) !IN Compressed field index no 2 READHE1A.79
*,CFI3(LEN_CFI3+1) !IN Compressed field index no 3 READHE1A.80
READHE1A.81
REAL READHE1A.82
& REALHD(LEN_REALHD) !IN Real header READHE1A.83
&,LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC) !IN Lev dep consts READHE1A.84
&,ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC) !IN Row dep consts READHE1A.85
&,COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC) !IN Col dep consts READHE1A.86
&,FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC) !IN Field dep consts READHE1A.87
&,EXTCNST(LEN_EXTCNST+1) !IN Extra constants READHE1A.88
&,DUMPHIST(LEN_DUMPHIST+1) !IN History block READHE1A.89
READHE1A.90
C Local arrays:------------------------------------------------ READHE1A.91
C None READHE1A.92
C ------------------------------------------------------------- READHE1A.93
C External subroutines called:--------------------------------- READHE1A.94
EXTERNAL IOERROR,POSERROR,PR_FIXHD,CHK_LOOK,BUFFIN READHE1A.95
C*------------------------------------------------------------- READHE1A.96
! Comdecks:---------------------------------------------------------- GDG0F401.1247
*CALL CSUBMODL GDG0F401.1248
*CALL CPPXREF GDG0F401.1249
*CALL PPXLOOK GDG0F401.1250
*CALL C_MDI READHE1A.97
*CALL CLOOKADD AD060593.7
*IF DEF,MPP GPB0F305.255
*CALL PARVARS GPB0F305.256
*ENDIF GPB0F305.257
C Local variables:--------------------------------------------- READHE1A.98
INTEGER K UDG2F305.480
INTEGER LEN_IO READHE1A.99
INTEGER FIXHD_152 ! Original value of FIXHD(152) @DYALLOC.3098
LOGICAL L_A_DUMP @DYALLOC.3099
LOGICAL L_O_DUMP @DYALLOC.3100
REAL A READHE1A.100
C ------------------------------------------------------------- READHE1A.101
READHE1A.102
ICODE=0 READHE1A.103
CMESSAGE=' ' READHE1A.104
READHE1A.105
CL 1. Buffer in fixed length header record READHE1A.106
READHE1A.107
CALL BUFFIN(NFTIN,FIXHD(1),LEN_FIXHD,LEN_IO,A) READHE1A.108
READHE1A.109
READHE1A.110
C Check for I/O errors READHE1A.111
IF(A.NE.-1.0.OR.LEN_IO.NE.LEN_FIXHD)THEN READHE1A.112
CALL IOERROR('buffer in of fixed length header',A,LEN_IO READHE1A.113
* ,LEN_FIXHD) READHE1A.114
CMESSAGE='READHEAD: I/O error' READHE1A.115
ICODE=1 READHE1A.116
RETURN READHE1A.117
ENDIF READHE1A.118
READHE1A.119
START_BLOCK=LEN_FIXHD+1 READHE1A.120
READHE1A.121
FIXHD_152 = FIXHD(152) ! Store original value @DYALLOC.3101
@DYALLOC.3102
C Test if atmos dump read in @DYALLOC.3103
L_A_DUMP = FIXHD(5).EQ.1 .AND. FIXHD(2).EQ.1 @DYALLOC.3104
* . AND . LEN_DATA.NE.IMDI @DYALLOC.3105
@DYALLOC.3106
C Test if ocean dump read in @DYALLOC.3107
L_O_DUMP = FIXHD(5).EQ.1 .AND. FIXHD(2).EQ.2 @DYALLOC.3108
* . AND . LEN_DATA.NE.IMDI @DYALLOC.3109
@DYALLOC.3110
IF (L_A_DUMP .OR. L_O_DUMP) THEN @DYALLOC.3111
IF (FIXHD(152).NE.LEN2_LOOKUP) THEN @DYALLOC.3112
CXX WRITE (6,*) 'FIXHD(152) being reset from ',FIXHD(152),' to ', @DYALLOC.3113
CXX * LEN2_LOOKUP @DYALLOC.3114
FIXHD(152) = LEN2_LOOKUP @DYALLOC.3115
ENDIF @DYALLOC.3116
*IF -DEF,MPP GPB0F401.300
IF (FIXHD(161).NE.LEN_DATA) THEN @DYALLOC.3117
CXX WRITE (6,*) 'FIXHD(161) being reset from ',FIXHD(161),' to ', @DYALLOC.3118
CXX * LEN_DATA @DYALLOC.3119
FIXHD(161) = LEN_DATA @DYALLOC.3120
ENDIF @DYALLOC.3121
*ENDIF GPB0F401.301
ENDIF @DYALLOC.3122
@DYALLOC.3123
C Check validity of data and print out fixed header information READHE1A.122
READHE1A.123
*IF DEF,MPP GPB0F305.258
IF (mype .EQ. 0) THEN GPB0F305.259
*ENDIF GPB0F305.260
CALL PR_FIXHD(FIXHD,LEN_FIXHD,LEN_INTHD,LEN_REALHD,LEN1_LEVDEPC READHE1A.124
*,LEN2_LEVDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC,LEN1_COLDEPC,LEN2_COLDEPC READHE1A.125
*,LEN1_FLDDEPC,LEN2_FLDDEPC,LEN_EXTCNST,LEN_DUMPHIST,LEN_CFI1 READHE1A.126
*,LEN_CFI2,LEN_CFI3,LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA READHE1A.127
*,ICODE,CMESSAGE) READHE1A.128
READHE1A.129
IF(ICODE.GT.0)RETURN READHE1A.130
READHE1A.131
*IF DEF,MPP GPB0F305.261
ENDIF GPB0F305.262
*ENDIF GPB0F305.263
CL 2. Buffer in integer constants READHE1A.132
READHE1A.133
IF(FIXHD(100).GT.0)THEN READHE1A.134
READHE1A.135
C Check for error in file pointers READHE1A.136
IF(FIXHD(100).NE.START_BLOCK)THEN READHE1A.137
CALL POSERROR('integer constants',START_BLOCK,100,FIXHD(100)) READHE1A.138
CMESSAGE='READHEAD: Addressing conflict' READHE1A.139
ICODE=2 READHE1A.140
RETURN READHE1A.141
ENDIF READHE1A.142
READHE1A.143
CALL BUFFIN(NFTIN,INTHD(1),FIXHD(101),LEN_IO,A) READHE1A.144
READHE1A.145
C Check for I/O errors READHE1A.146
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(101))THEN READHE1A.147
CALL IOERROR('buffer in of integer constants',A,LEN_IO, READHE1A.148
* FIXHD(101)) READHE1A.149
CMESSAGE='READHEAD: I/O error' READHE1A.150
ICODE=3 READHE1A.151
RETURN READHE1A.152
ENDIF READHE1A.153
READHE1A.154
START_BLOCK=START_BLOCK+FIXHD(101) READHE1A.155
READHE1A.156
ENDIF READHE1A.157
READHE1A.158
CL 3. Buffer in real constants READHE1A.159
READHE1A.160
IF(FIXHD(105).GT.0)THEN READHE1A.161
READHE1A.162
C Check for error in file pointers READHE1A.163
IF(FIXHD(105).NE.START_BLOCK)THEN READHE1A.164
CALL POSERROR('real constants',START_BLOCK,105,FIXHD(105)) READHE1A.165
CMESSAGE='READHEAD: Addressing conflict' READHE1A.166
ICODE=4 READHE1A.167
RETURN READHE1A.168
ENDIF READHE1A.169
READHE1A.170
C Check for I/O errors READHE1A.171
CALL BUFFIN(NFTIN,REALHD(1),FIXHD(106),LEN_IO,A) READHE1A.172
READHE1A.173
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(106))THEN READHE1A.174
CALL IOERROR('buffer in of real constants',A,LEN_IO, READHE1A.175
* FIXHD(106)) READHE1A.176
CMESSAGE='READHEAD: I/O error' READHE1A.177
ICODE=5 READHE1A.178
RETURN READHE1A.179
ENDIF READHE1A.180
READHE1A.181
START_BLOCK=START_BLOCK+FIXHD(106) READHE1A.182
READHE1A.183
READHE1A.184
ENDIF READHE1A.185
READHE1A.186
CL 4. Buffer in level dependent constants READHE1A.187
READHE1A.188
IF(FIXHD(110).GT.0.AND.LEN1_LEVDEPC.NE.0)THEN AD221292.4
READHE1A.190
C Check for error in file pointers READHE1A.191
IF(FIXHD(110).NE.START_BLOCK)THEN READHE1A.192
CALL POSERROR('level dependent constants', READHE1A.193
* START_BLOCK,110,FIXHD(110)) READHE1A.194
CMESSAGE='READHEAD: Addressing conflict' READHE1A.195
ICODE=6 READHE1A.196
RETURN READHE1A.197
ENDIF READHE1A.198
READHE1A.199
CALL BUFFIN(NFTIN,LEVDEPC(1),FIXHD(111)*FIXHD(112),LEN_IO,A) READHE1A.200
READHE1A.201
C Check for I/O errors READHE1A.202
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(111)*FIXHD(112))THEN READHE1A.203
CALL IOERROR('buffer in of level dependent constants',A,LEN_IO, READHE1A.204
* FIXHD(111)*FIXHD(112)) READHE1A.205
CMESSAGE='READHEAD: I/O error' READHE1A.206
ICODE=7 READHE1A.207
RETURN READHE1A.208
ENDIF READHE1A.209
READHE1A.210
START_BLOCK=START_BLOCK+FIXHD(111)*FIXHD(112) READHE1A.211
READHE1A.212
*IF DEF,MPP GPB0F305.264
IF (mype .EQ. 0) THEN GPB0F305.265
*ENDIF GPB0F305.266
WRITE(6,'('' '')') READHE1A.213
WRITE(6,'('' LEVEL DEPENDENT CONSTANTS'')') READHE1A.214
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(111)*FIXHD(112) READHE1A.215
READHE1A.216
*IF DEF,MPP GPB0F305.267
ENDIF ! mype .EQ. 0 GPB0F305.268
*ENDIF GPB0F305.269
ENDIF READHE1A.217
READHE1A.218
CL 5. Buffer in row dependent constants READHE1A.219
READHE1A.220
IF(FIXHD(115).GT.0.AND.LEN1_ROWDEPC.NE.0)THEN AD221292.5
READHE1A.222
C Check for error in file pointers READHE1A.223
IF(FIXHD(115).NE.START_BLOCK)THEN READHE1A.224
CALL POSERROR('row dependent constants', READHE1A.225
* START_BLOCK,115,FIXHD(115)) READHE1A.226
CMESSAGE='READHEAD: Addressing conflict' READHE1A.227
ICODE=8 READHE1A.228
RETURN READHE1A.229
ENDIF READHE1A.230
READHE1A.231
CALL BUFFIN(NFTIN,ROWDEPC(1),FIXHD(116)*FIXHD(117),LEN_IO,A) READHE1A.232
READHE1A.233
C Check for I/O errors READHE1A.234
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(116)*FIXHD(117))THEN READHE1A.235
CALL IOERROR('buffer in of row dependent constants',A,LEN_IO, READHE1A.236
* FIXHD(116)*FIXHD(117)) READHE1A.237
CMESSAGE='READHEAD: I/O error' READHE1A.238
ICODE=9 READHE1A.239
RETURN READHE1A.240
ENDIF READHE1A.241
READHE1A.242
READHE1A.243
START_BLOCK=START_BLOCK+FIXHD(116)*FIXHD(117) READHE1A.244
READHE1A.245
*IF DEF,MPP GPB0F305.270
IF (mype .EQ. 0) THEN GPB0F305.271
*ENDIF GPB0F305.272
WRITE(6,'('' '')') READHE1A.246
WRITE(6,'('' ROW DEPENDENT CONSTANTS'')') READHE1A.247
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(116)*FIXHD(117) READHE1A.248
READHE1A.249
*IF DEF,MPP GPB0F305.273
ENDIF ! mype .EQ. 0 GPB0F305.274
*ENDIF GPB0F305.275
ENDIF READHE1A.250
READHE1A.251
CL 6. Buffer in column dependent constants READHE1A.252
READHE1A.253
IF(FIXHD(120).GT.0.AND.LEN1_COLDEPC.NE.0)THEN AD221292.6
READHE1A.255
C Check for error in file pointers READHE1A.256
IF(FIXHD(120).NE.START_BLOCK)THEN READHE1A.257
CALL POSERROR('column dependent constants', READHE1A.258
* START_BLOCK,120,FIXHD(120)) READHE1A.259
CMESSAGE='READHEAD: Addressing conflict' READHE1A.260
ICODE=10 READHE1A.261
RETURN READHE1A.262
ENDIF READHE1A.263
READHE1A.264
CALL BUFFIN(NFTIN,COLDEPC(1),FIXHD(121)*FIXHD(122),LEN_IO,A) READHE1A.265
READHE1A.266
C Check for I/O errors READHE1A.267
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(121)*FIXHD(122))THEN READHE1A.268
CALL IOERROR('buffer in of column dependent constants',A,LEN_IO, READHE1A.269
* FIXHD(121)*FIXHD(122)) READHE1A.270
CMESSAGE='READHEAD: I/O error' READHE1A.271
ICODE=11 READHE1A.272
RETURN READHE1A.273
ENDIF READHE1A.274
READHE1A.275
START_BLOCK=START_BLOCK+FIXHD(121)*FIXHD(122) READHE1A.276
READHE1A.277
*IF DEF,MPP GPB0F305.276
IF (mype .EQ. 0) THEN GPB0F305.277
*ENDIF GPB0F305.278
WRITE(6,'('' '')') READHE1A.278
WRITE(6,'('' COLUMN DEPENDENT CONSTANTS'')') READHE1A.279
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(121)*FIXHD(122) READHE1A.280
READHE1A.281
*IF DEF,MPP GPB0F305.279
ENDIF ! mype .EQ. 0 GPB0F305.280
*ENDIF GPB0F305.281
ENDIF READHE1A.282
READHE1A.283
CL 7. Buffer in constants stored as fields READHE1A.284
READHE1A.285
IF(FIXHD(125).GT.0.AND.LEN1_FLDDEPC.NE.0)THEN AD221292.7
READHE1A.287
C Check for error in file pointers READHE1A.288
IF(FIXHD(125).NE.START_BLOCK)THEN READHE1A.289
CALL POSERROR('fields of constants', READHE1A.290
* START_BLOCK,125,FIXHD(125)) READHE1A.291
CMESSAGE='READHEAD: Addressing conflict' READHE1A.292
ICODE=12 READHE1A.293
RETURN READHE1A.294
ENDIF READHE1A.295
READHE1A.296
CALL BUFFIN(NFTIN,FLDDEPC(1),FIXHD(126)*FIXHD(127),LEN_IO,A) READHE1A.297
READHE1A.298
C Check for I/O errors READHE1A.299
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(126)*FIXHD(127))THEN READHE1A.300
CALL IOERROR('buffer in of field dependent constants',A,LEN_IO, READHE1A.301
* FIXHD(126)*FIXHD(127)) READHE1A.302
CMESSAGE='READHEAD: I/O error' READHE1A.303
ICODE=13 READHE1A.304
RETURN READHE1A.305
ENDIF READHE1A.306
READHE1A.307
START_BLOCK=START_BLOCK+FIXHD(126)*FIXHD(127) READHE1A.308
READHE1A.309
*IF DEF,MPP GPB0F305.282
IF (mype .EQ. 0) THEN GPB0F305.283
*ENDIF GPB0F305.284
WRITE(6,'('' '')') READHE1A.310
WRITE(6,'('' FIELD DEPENDENT CONSTANTS'')') READHE1A.311
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(126)*FIXHD(127) READHE1A.312
READHE1A.313
*IF DEF,MPP GPB0F305.285
ENDIF ! mype .EQ. 0 GPB0F305.286
*ENDIF GPB0F305.287
ENDIF READHE1A.314
READHE1A.315
CL 8. Buffer in extra constants READHE1A.316
READHE1A.317
IF(FIXHD(130).GT.0.AND.LEN_EXTCNST.NE.0)THEN AD221292.8
READHE1A.319
C Check for error in file pointers READHE1A.320
IF(FIXHD(130).NE.START_BLOCK)THEN READHE1A.321
CALL POSERROR('extra constants', READHE1A.322
* START_BLOCK,130,FIXHD(130)) READHE1A.323
CMESSAGE='READHEAD: Addressing conflict' READHE1A.324
ICODE=14 READHE1A.325
RETURN READHE1A.326
ENDIF READHE1A.327
READHE1A.328
CALL BUFFIN(NFTIN,EXTCNST(1),FIXHD(131),LEN_IO,A) READHE1A.329
READHE1A.330
C Check for I/O errors READHE1A.331
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(131))THEN READHE1A.332
CALL IOERROR('buffer in extra constants',A,LEN_IO, READHE1A.333
* FIXHD(131)) READHE1A.334
CMESSAGE='READHEAD: I/O error' READHE1A.335
ICODE=15 READHE1A.336
RETURN READHE1A.337
ENDIF READHE1A.338
READHE1A.339
START_BLOCK=START_BLOCK+FIXHD(131) READHE1A.340
READHE1A.341
*IF DEF,MPP GPB0F305.288
IF (mype .EQ. 0) THEN GPB0F305.289
*ENDIF GPB0F305.290
WRITE(6,'('' '')') READHE1A.342
WRITE(6,'('' EXTRA CONSTANTS'')') READHE1A.343
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(131) READHE1A.344
READHE1A.345
*IF DEF,MPP GPB0F305.291
ENDIF ! mype .EQ. 0 GPB0F305.292
*ENDIF GPB0F305.293
ENDIF READHE1A.346
READHE1A.347
CL 9. Buffer in temporary history block READHE1A.348
READHE1A.349
IF(FIXHD(135).GT.0.AND.LEN_DUMPHIST.NE.0)THEN AD221292.9
READHE1A.351
C Check for error in file pointers READHE1A.352
IF(FIXHD(135).NE.START_BLOCK)THEN READHE1A.353
CALL POSERROR('history', READHE1A.354
* START_BLOCK,136,FIXHD(136)) READHE1A.355
CMESSAGE='READHEAD: Addressing conflict' READHE1A.356
ICODE=16 READHE1A.357
RETURN READHE1A.358
ENDIF READHE1A.359
READHE1A.360
CALL BUFFIN(NFTIN,DUMPHIST(1),FIXHD(136),LEN_IO,A) READHE1A.361
READHE1A.362
C Check for I/O errors READHE1A.363
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(136))THEN READHE1A.364
CALL IOERROR('buffer in of history file',A,LEN_IO, READHE1A.365
* FIXHD(136)) READHE1A.366
CMESSAGE='READHEAD: I/O error' READHE1A.367
ICODE=17 READHE1A.368
RETURN READHE1A.369
ENDIF READHE1A.370
READHE1A.371
START_BLOCK=START_BLOCK+FIXHD(136) READHE1A.372
READHE1A.373
*IF DEF,MPP GPB0F305.294
IF (mype .EQ. 0) THEN GPB0F305.295
*ENDIF GPB0F305.296
WRITE(6,'('' '')') READHE1A.374
WRITE(6,'('' TEMPORARY HISTORY BLOCK'')') READHE1A.375
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(136) READHE1A.376
READHE1A.377
*IF DEF,MPP GPB0F305.297
ENDIF ! mype .EQ. 0 GPB0F305.298
*ENDIF GPB0F305.299
ENDIF READHE1A.378
READHE1A.379
CL 10. Buffer in compressed field index1 READHE1A.380
READHE1A.381
IF(FIXHD(140).GT.0.AND.LEN_CFI2.NE.0)THEN AD221292.10
READHE1A.383
C Check for error in file pointers READHE1A.384
READHE1A.385
IF(FIXHD(140).NE.START_BLOCK)THEN READHE1A.386
CALL POSERROR('compressed field index1', READHE1A.387
* START_BLOCK,140,FIXHD(140)) READHE1A.388
CMESSAGE='READHEAD: Addressing conflict' READHE1A.389
ICODE=18 READHE1A.390
RETURN READHE1A.391
ENDIF READHE1A.392
READHE1A.393
CALL BUFFIN(NFTIN,CFI1(1),FIXHD(141),LEN_IO,A) READHE1A.394
READHE1A.395
C Check for I/O errors READHE1A.396
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(141))THEN READHE1A.397
CALL IOERROR('buffer in of compressed index1',A,LEN_IO, READHE1A.398
* FIXHD(141)) READHE1A.399
CMESSAGE='READHEAD: I/O error' READHE1A.400
ICODE=19 READHE1A.401
RETURN READHE1A.402
ENDIF READHE1A.403
READHE1A.404
START_BLOCK=START_BLOCK+FIXHD(141) READHE1A.405
READHE1A.406
*IF DEF,MPP GPB0F305.300
IF (mype .EQ. 0) THEN GPB0F305.301
*ENDIF GPB0F305.302
WRITE(6,'('' '')') READHE1A.407
WRITE(6,'('' COMPRESSED FIELD INDEX NO 1'')') READHE1A.408
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(141) READHE1A.409
READHE1A.410
*IF DEF,MPP GPB0F305.303
ENDIF ! mype .EQ. 0 GPB0F305.304
*ENDIF GPB0F305.305
ENDIF READHE1A.411
READHE1A.412
CL 11. Buffer in compressed field index2 READHE1A.413
READHE1A.414
IF(FIXHD(142).GT.0.AND.LEN_CFI2.NE.0)THEN AD221292.11
READHE1A.416
C Check for error in file pointers READHE1A.417
IF(FIXHD(142).NE.START_BLOCK)THEN READHE1A.418
CALL POSERROR('compressed field index2', READHE1A.419
* START_BLOCK,142,FIXHD(142)) READHE1A.420
CMESSAGE='READHEAD: Addressing conflict' READHE1A.421
ICODE=20 READHE1A.422
RETURN READHE1A.423
ENDIF READHE1A.424
READHE1A.425
CALL BUFFIN(NFTIN,CFI2(1),FIXHD(143),LEN_IO,A) READHE1A.426
READHE1A.427
C Check for I/O errors READHE1A.428
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(143))THEN READHE1A.429
CALL IOERROR('buffer in of compressed index2',A,LEN_IO, READHE1A.430
* FIXHD(143)) READHE1A.431
CMESSAGE='READHEAD: I/O error' READHE1A.432
ICODE=21 READHE1A.433
RETURN READHE1A.434
ENDIF READHE1A.435
READHE1A.436
START_BLOCK=START_BLOCK+FIXHD(143) READHE1A.437
READHE1A.438
*IF DEF,MPP GPB0F305.306
IF (mype .EQ. 0) THEN GPB0F305.307
*ENDIF GPB0F305.308
WRITE(6,'('' '')') READHE1A.439
WRITE(6,'('' COMPRESSED FIELD INDEX NO 2'')') READHE1A.440
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(143) READHE1A.441
READHE1A.442
*IF DEF,MPP GPB0F305.309
ENDIF ! mype .EQ. 0 GPB0F305.310
*ENDIF GPB0F305.311
ENDIF READHE1A.443
READHE1A.444
CL 12. Buffer in compressed field index3 READHE1A.445
READHE1A.446
IF(FIXHD(144).GT.0.AND.LEN_CFI3.NE.0)THEN AD221292.12
READHE1A.448
C Check for error in file pointers READHE1A.449
IF(FIXHD(144).NE.START_BLOCK)THEN READHE1A.450
CALL POSERROR('compressed field index3', READHE1A.451
* START_BLOCK,144,FIXHD(144)) READHE1A.452
CMESSAGE='READHEAD: Addressing conflict' READHE1A.453
ICODE=22 READHE1A.454
RETURN READHE1A.455
ENDIF READHE1A.456
READHE1A.457
CALL BUFFIN(NFTIN,CFI3(1),FIXHD(145),LEN_IO,A) READHE1A.458
READHE1A.459
C Check for I/O errors READHE1A.460
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(145))THEN READHE1A.461
CALL IOERROR('buffer in of compressed index3',A,LEN_IO, READHE1A.462
* FIXHD(145)) READHE1A.463
CMESSAGE='READHEAD: I/O error' READHE1A.464
ICODE=23 READHE1A.465
RETURN READHE1A.466
ENDIF READHE1A.467
READHE1A.468
START_BLOCK=START_BLOCK+FIXHD(145) READHE1A.469
READHE1A.470
*IF DEF,MPP GPB0F305.312
IF (mype .EQ. 0) THEN GPB0F305.313
*ENDIF GPB0F305.314
WRITE(6,'('' '')') READHE1A.471
WRITE(6,'('' COMPRESSED FIELD INDEX NO 3'')') READHE1A.472
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(145) READHE1A.473
READHE1A.474
*IF DEF,MPP GPB0F305.315
ENDIF ! mype .EQ. 0 GPB0F305.316
*ENDIF GPB0F305.317
ENDIF READHE1A.475
READHE1A.476
CL 13. Buffer in lookup table READHE1A.477
READHE1A.478
IF(FIXHD(150).GT.0)THEN READHE1A.479
READHE1A.480
C Supress checking if not full dump AD221292.13
IF(LEN_DUMPHIST.NE.0)THEN AD221292.14
C Check for error in file pointers READHE1A.481
IF(FIXHD(150).NE.START_BLOCK)THEN READHE1A.482
CALL POSERROR('lookup table', READHE1A.483
* START_BLOCK,150,FIXHD(150)) READHE1A.484
CMESSAGE='READHEAD: Addressing conflict' READHE1A.485
ICODE=24 READHE1A.486
RETURN READHE1A.487
ENDIF READHE1A.488
ENDIF AD221292.15
READHE1A.489
C Move to start of Look Up Table @DYALLOC.3124
CALL SETPOS(NFTIN,FIXHD(150)-1,ICODE) GTD0F400.125
@DYALLOC.3125
C Read in fields from LOOKUP table @DYALLOC.3126
CALL BUFFIN(NFTIN,LOOKUP(1,1),FIXHD(151)*FIXHD(152),LEN_IO,A) READHE1A.490
READHE1A.491
C Check for I/O errors READHE1A.492
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(151)*FIXHD(152))THEN READHE1A.493
CALL IOERROR('buffer in of lookup table',A,LEN_IO, READHE1A.494
* FIXHD(151)*FIXHD(152)) READHE1A.495
CMESSAGE='READHEAD: I/O error' READHE1A.496
ICODE=25 READHE1A.497
RETURN READHE1A.498
ENDIF READHE1A.499
READHE1A.500
C Point to start of data section ( Use original FIXHD(152) ) @DYALLOC.3127
START_BLOCK=START_BLOCK+FIXHD(151)*FIXHD_152 @DYALLOC.3128
READHE1A.502
*IF DEF,MPP GPB0F305.318
IF (mype .EQ. 0) THEN GPB0F305.319
*ENDIF GPB0F305.320
WRITE(6,'('' '')') READHE1A.503
WRITE(6,'('' LOOKUP TABLE'')') READHE1A.504
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(151)*FIXHD(152) READHE1A.505
READHE1A.506
IF (FIXHD(152).LT.FIXHD_152) THEN @DYALLOC.3129
WRITE(6,'('' '')') @DYALLOC.3130
WRITE(6,'('' '',I6,'' Entries in Look Up Table.'')') FIXHD_152 @DYALLOC.3131
WRITE(6,'('' '',I6,'' Entries read in.'')') FIXHD(152) @DYALLOC.3132
ENDIF @DYALLOC.3133
READHE1A.507
*IF DEF,MPP GPB0F305.321
ENDIF ! mype .EQ. 0 GPB0F305.322
*ENDIF GPB0F305.323
!--------------------------------------------------------------- UDG7F400.428
! Reset LOOKUP(45) if not set UDG7F400.429
!--------------------------------------------------------------- UDG7F400.430
UDG7F400.431
DO K=1,LEN2_LOOKUP UDG7F400.432
IF(LOOKUP(45,K).EQ.0.OR.LOOKUP(45,K).EQ.IMDI)THEN UDG7F400.433
UDG7F400.434
!Section 0: Prognostic fields. UDG7F400.435
IF(LOOKUP(42,K).LE.100.OR. UDG7F400.436
& (LOOKUP(42,K).GE.200.AND.LOOKUP(42,K).LE.205))THEN UDG7F400.437
LOOKUP(45,K)=1 UDG7F400.438
UDG7F400.439
ELSE IF((LOOKUP(42,K).GT.100.AND.LOOKUP(42,K).LE.176).OR. UDG7F400.440
& (LOOKUP(42,K).GE.180.AND.LOOKUP(42,K).LT.200))THEN UDG7F400.441
LOOKUP(45,K)=2 UDG7F400.442
UDG7F400.443
ELSE IF((LOOKUP(42,K).GE.177.AND.LOOKUP(42,K).LE.179).OR. UDG7F400.444
& (LOOKUP(42,K).GE.210.AND.LOOKUP(42,K).LE.212))THEN UDG7F400.445
LOOKUP(45,K)=3 UDG7F400.446
UDG7F400.447
! Sections 1 - 99: Diagnostic fields UDG7F400.448
ELSE IF(LOOKUP(42,K).GE.1000.AND.LOOKUP(42,K).LE.29999)THEN UDG7F400.449
IF((LOOKUP(42,K).GE.21177.AND.LOOKUP(42,K).LE.21179).OR. UDG7F400.450
& (LOOKUP(42,K).GE.21225.AND.LOOKUP(42,K).LE.21227).OR. UDG7F400.451
& (LOOKUP(42,K).GE.22177.AND.LOOKUP(42,K).LE.22179).OR. UDG7F400.452
& (LOOKUP(42,K).GE.22225.AND.LOOKUP(42,K).LE.22227).OR. UDG7F400.453
& (LOOKUP(42,K).GE.23177.AND.LOOKUP(42,K).LE.23179).OR. UDG7F400.454
& (LOOKUP(42,K).GE.23225.AND.LOOKUP(42,K).LE.23227).OR. UDG7F400.455
& (LOOKUP(42,K).GE.24177.AND.LOOKUP(42,K).LE.24179).OR. UDG7F400.456
& (LOOKUP(42,K).GE.24225.AND.LOOKUP(42,K).LE.24227))THEN UDG7F400.457
LOOKUP(45,K)=3 !Slab diagnostic UDG7F400.458
UDG7F400.459
ELSE UDG7F400.460
LOOKUP(45,K)=1 !Atmosphere diagnostic UDG7F400.461
UDG7F400.462
END IF UDG7F400.463
UDG7F400.464
ELSE IF(LOOKUP(42,K).GE.30000.AND.LOOKUP(42,K).LE.99999)THEN UDG7F400.465
IF(LOOKUP(42,K).GE.40000.AND.LOOKUP(42,K).LE.40999)THEN UDG7F400.466
LOOKUP(45,K)=3 !Slab diagnostic UDG7F400.467
UDG7F400.468
ELSE UDG7F400.469
LOOKUP(45,K)=2 !Ocean diagnostic UDG7F400.470
UDG7F400.471
END IF UDG7F400.472
UDG7F400.473
ELSE UDG7F400.474
WRITE(6,*) 'WARNING: User defined field found - ', UDG7F400.475
& 'STASH code : ', LOOKUP(42,K) UDG7F400.476
WRITE(6,*) ' Internal model number can not be defined.' UDG7F400.477
WRITE(6,*) ' Setting internal model number to atmosphere.' UDG7F400.478
LOOKUP(45,K)=1 UDG7F400.479
UDG7F400.480
ENDIF UDG7F400.481
UDG7F400.482
ENDIF UDG7F400.483
UDG7F400.484
ENDDO UDG7F400.485
C--------------------------------------------------------------- READHE1A.508
C Reset LOOKUP headers if dump created earlier than vn2.8 READHE1A.509
C--------------------------------------------------------------- READHE1A.510
READHE1A.511
IF(FIXHD(12).LT.208)THEN READHE1A.512
CALL NEWPACK(LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP) READHE1A.513
ENDIF READHE1A.514
READHE1A.515
C Check LOOKUP for consistency with PARAMETER statements READHE1A.516
IF(LOOKUP(LBNREC,1).EQ.0 . OR. AD060593.8
C Prog lookups in dump before vn3.2: AD060593.9
* (LOOKUP(LBNREC,1).EQ.IMDI. AND. FIXHD(12).LE.301)) THEN AD060593.10
IF(LEN_DATA.NE.IMDI)THEN READHE1A.517
CALL CHK_LOOK(FIXHD,LOOKUP,LEN1_LOOKUP,LEN_DATA, GDG0F401.1251
*CALL ARGPPX GDG0F401.1252
& ICODE,CMESSAGE) GDG0F401.1253
ENDIF READHE1A.520
ENDIF AD060593.11
READHE1A.521
ENDIF READHE1A.522
READHE1A.523
RETURN READHE1A.524
END READHE1A.525
*ENDIF READHE1A.526