SUBROUTINE WRITHEAD(NFTOUT,FIXHD,LEN_FIXHD, ! Intent (In) 10,56GDG0F401.1640
& INTHD,LEN_INTHD, GDG0F401.1641
& REALHD,LEN_REALHD, GDG0F401.1642
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GDG0F401.1643
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GDG0F401.1644
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GDG0F401.1645
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GDG0F401.1646
& EXTCNST,LEN_EXTCNST, GDG0F401.1647
& DUMPHIST,LEN_DUMPHIST, GDG0F401.1648
& CFI1,LEN_CFI1, GDG0F401.1649
& CFI2,LEN_CFI2, GDG0F401.1650
& CFI3,LEN_CFI3, GDG0F401.1651
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA, GDG0F401.1652
*IF DEF,IEEE GDG0F401.1653
& IEEE_TYPE, GDG0F401.1654
& LPVP, UDG2F404.101
*ENDIF GDG0F401.1655
*CALL ARGPPX 
GDG0F401.1656
& START_BLOCK,ICODE,CMESSAGE) ! Intent (Out) GDG0F401.1657
WRITHE1A.49
IMPLICIT NONE WRITHE1A.50
WRITHE1A.51
INTEGER WRITHE1A.52
* NFTOUT !IN Unit no of dump WRITHE1A.53
*,LEN_FIXHD !IN Length of fixed length header WRITHE1A.54
*,LEN_INTHD !IN Length of integer header WRITHE1A.55
*,LEN_REALHD !IN Length of real header WRITHE1A.56
*,LEN1_LEVDEPC !IN 1st dim of level dep consts WRITHE1A.57
*,LEN2_LEVDEPC !IN 2ndt dim of level dep consts WRITHE1A.58
*,LEN1_ROWDEPC !IN 1st dim of row dep consts WRITHE1A.59
*,LEN2_ROWDEPC !IN 2nd dim of row dep consts WRITHE1A.60
&,LEN1_COLDEPC !IN 1st dim of column dep consts WRITHE1A.61
&,LEN2_COLDEPC !IN 2nd dim of column dep consts WRITHE1A.62
&,LEN1_FLDDEPC !IN 1st dim of field dep consts WRITHE1A.63
&,LEN2_FLDDEPC !IN 2nd dim of field dep consts WRITHE1A.64
&,LEN_EXTCNST !IN Length of extra constants WRITHE1A.65
&,LEN_DUMPHIST !IN Length of history block WRITHE1A.66
&,LEN_CFI1 !IN Length of comp field index 1 WRITHE1A.67
&,LEN_CFI2 !IN Length of comp field index 2 WRITHE1A.68
&,LEN_CFI3 !IN Length of comp field index 3 WRITHE1A.69
&,LEN1_LOOKUP !IN 1st dim of lookup WRITHE1A.70
&,LEN2_LOOKUP !IN 2nd dim of lookup WRITHE1A.71
WRITHE1A.72
INTEGER WRITHE1A.73
* LEN_DATA !IN Length of model data WRITHE1A.74
*,START_BLOCK !OUT Pointer to position of each block. WRITHE1A.75
* !Should point to start of model data block on exit WRITHE1A.76
*,ICODE !OUT Return code; successful=0 WRITHE1A.77
* ! error > 0 WRITHE1A.78
*IF DEF,IEEE WRITHE1A.79
*,IEEE_TYPE !IN IEEE precision WRITHE1A.80
UDG2F404.102
LOGICAL LPVP !IN True if output in PVP format UDG2F404.103
*ENDIF WRITHE1A.81
WRITHE1A.82
CHARACTER*(80) TS150793.215
* CMESSAGE !OUT Error message if ICODE > 0 WRITHE1A.84
WRITHE1A.85
INTEGER WRITHE1A.86
* FIXHD(LEN_FIXHD) !IN Fixed length header WRITHE1A.87
*,INTHD(LEN_INTHD) !IN Integer header WRITHE1A.88
*,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) !IN PP lookup tables WRITHE1A.89
*,CFI1(LEN_CFI1+1) !IN Compressed field index no 1 WRITHE1A.90
*,CFI2(LEN_CFI2+1) !IN Compressed field index no 2 WRITHE1A.91
*,CFI3(LEN_CFI3+1) !IN Compressed field index no 3 WRITHE1A.92
WRITHE1A.93
REAL WRITHE1A.94
& REALHD(LEN_REALHD) !IN Real header WRITHE1A.95
&,LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC) !IN Lev dep consts WRITHE1A.96
&,ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC) !IN Row dep consts WRITHE1A.97
&,COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC) !IN Col dep consts WRITHE1A.98
&,FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC) !IN Field dep consts WRITHE1A.99
&,EXTCNST(LEN_EXTCNST+1) !IN Extra constants WRITHE1A.100
&,DUMPHIST(LEN_DUMPHIST+1) !IN History block WRITHE1A.101
WRITHE1A.102
WRITHE1A.103
C Local arrays:------------------------------------------------ WRITHE1A.104
C None WRITHE1A.105
*IF DEF,IEEE WRITHE1A.106
WRITHE1A.107
INTEGER CRI2IEG,CRAY2CRI,CRI2CRAY UDG2F404.104
EXTERNAL CRI2IEG,CRAY2CRI,CRI2CRAY UDG2F404.105
WRITHE1A.110
INTEGER WRITHE1A.111
* FIXHD_OUT(LEN_FIXHD) ! Fixed length header WRITHE1A.112
*,INTHD_OUT(LEN_INTHD) ! Integer header WRITHE1A.113
*,LOOKUP_O32(LEN1_LOOKUP/2,LEN2_LOOKUP) !PP lookup tables (32-bit) UTS0F400.1
*,LOOKUP_O64(LEN1_LOOKUP,LEN2_LOOKUP) !PP lookup tables (64-bit) UTS0F400.2
*,CFI1_OUT(LEN_CFI1+1) ! Compressed field index no 1 WRITHE1A.116
*,CFI2_OUT(LEN_CFI2+1) ! Compressed field index no 2 WRITHE1A.117
*,CFI3_OUT(LEN_CFI3+1) ! Compressed field index no 3 WRITHE1A.118
*,I,J WRITHE1A.119
WRITHE1A.120
REAL WRITHE1A.121
& REALHD_OUT(LEN_REALHD) ! Real header WRITHE1A.122
&,LEVDEPC_OUT(1+LEN1_LEVDEPC*LEN2_LEVDEPC) ! Lev dep consts WRITHE1A.123
&,ROWDEPC_OUT(1+LEN1_ROWDEPC*LEN2_ROWDEPC) ! Row dep consts WRITHE1A.124
&,COLDEPC_OUT(1+LEN1_COLDEPC*LEN2_COLDEPC) ! Col dep consts WRITHE1A.125
&,FLDDEPC_OUT(1+LEN1_FLDDEPC*LEN2_FLDDEPC) ! Field dep consts WRITHE1A.126
&,EXTCNST_OUT(LEN_EXTCNST+1) ! Extra constants WRITHE1A.127
&,DUMPHIST_OUT(LEN_DUMPHIST+1) ! History block WRITHE1A.128
WRITHE1A.129
*ENDIF WRITHE1A.130
*IF DEF,MPP GPB0F305.427
*CALL PARVARS GPB0F305.428
*ENDIF GPB0F305.429
C ------------------------------------------------------------- WRITHE1A.131
C External subroutines called:--------------------------------- WRITHE1A.132
EXTERNAL IOERROR,POSERROR,PR_FIXHD,CHK_LOOK,BUFFOUT WRITHE1A.133
C*------------------------------------------------------------- WRITHE1A.134
C Local variables:--------------------------------------------- WRITHE1A.135
INTEGER LEN_IO WRITHE1A.136
REAL A WRITHE1A.137
C ------------------------------------------------------------- WRITHE1A.138
! Comdecks:---------------------------------------------------------- GDG0F401.1658
*CALL CSUBMODL GDG0F401.1659
*CALL CPPXREF GDG0F401.1660
*CALL PPXLOOK GDG0F401.1661
C ------------------------------------------------------------- GDG0F401.1662
ICODE=0 WRITHE1A.139
CMESSAGE=' ' WRITHE1A.140
WRITHE1A.141
CL 1. Buffer out fixed length header record WRITHE1A.142
WRITHE1A.143
*IF DEF,IEEE WRITHE1A.144
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.145
I= CRI2IEG(2,LEN_FIXHD,FIXHD_OUT,0,FIXHD,1,64,IEEE_TYPE) UDG1F402.38
CALL BUFFO32(NFTOUT,FIXHD_OUT,LEN_FIXHD,LEN_IO,A) WRITHE1A.147
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.148
CALL BUFFOUT(NFTOUT,FIXHD(1),LEN_FIXHD,LEN_IO,A) WRITHE1A.149
ENDIF WRITHE1A.150
*ELSE WRITHE1A.151
CALL BUFFOUT(NFTOUT,FIXHD(1),LEN_FIXHD,LEN_IO,A) WRITHE1A.152
*ENDIF WRITHE1A.153
WRITHE1A.154
WRITHE1A.155
C Check for I/O errors WRITHE1A.156
IF(A.NE.-1.0.OR.LEN_IO.NE.LEN_FIXHD)THEN WRITHE1A.157
CALL IOERROR('buffer out of fixed length header',A,LEN_IO WRITHE1A.158
* ,LEN_FIXHD) WRITHE1A.159
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.160
ICODE=1 WRITHE1A.161
RETURN WRITHE1A.162
ENDIF WRITHE1A.163
WRITHE1A.164
START_BLOCK=LEN_FIXHD+1 WRITHE1A.165
WRITHE1A.166
*IF DEF,DIAG81 WRITHE1A.167
C Check validity of data and print out fixed header information WRITHE1A.168
WRITHE1A.169
CALL PR_FIXHD(FIXHD,LEN_FIXHD,LEN_INTHD,LEN_REALHD,LEN1_LEVDEPC WRITHE1A.170
*,LEN2_LEVDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC,LEN1_COLDEPC,LEN2_COLDEPC WRITHE1A.171
*,LEN1_FLDDEPC,LEN2_FLDDEPC,LEN_EXTCNST,LEN_DUMPHIST,LEN_CFI1 WRITHE1A.172
*,LEN_CFI2,LEN_CFI3,LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA WRITHE1A.173
*,ICODE,CMESSAGE) WRITHE1A.174
WRITHE1A.175
IF(ICODE.GT.0)RETURN WRITHE1A.176
*ENDIF WRITHE1A.177
WRITHE1A.178
CL 2. Buffer out integer constants WRITHE1A.179
WRITHE1A.180
IF(FIXHD(100).GT.0)THEN WRITHE1A.181
WRITHE1A.182
*IF DEF,DIAG81 WRITHE1A.183
C Check for error in file pointers WRITHE1A.184
IF(FIXHD(100).NE.START_BLOCK)THEN WRITHE1A.185
CALL POSERROR('integer constants',START_BLOCK,100,FIXHD(100)) WRITHE1A.186
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.187
ICODE=2 WRITHE1A.188
RETURN WRITHE1A.189
ENDIF WRITHE1A.190
*ENDIF WRITHE1A.191
WRITHE1A.192
*IF DEF,IEEE WRITHE1A.193
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.194
I= CRI2IEG(2,FIXHD(101),INTHD_OUT,0,INTHD,1,64,IEEE_TYPE) UDG1F402.42
CALL BUFFO32(NFTOUT,INTHD_OUT,FIXHD(101),LEN_IO,A) WRITHE1A.196
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.197
CALL BUFFOUT(NFTOUT,INTHD(1),FIXHD(101),LEN_IO,A) WRITHE1A.198
ENDIF WRITHE1A.199
*ELSE WRITHE1A.200
CALL BUFFOUT(NFTOUT,INTHD(1),FIXHD(101),LEN_IO,A) WRITHE1A.201
*ENDIF WRITHE1A.202
WRITHE1A.203
C Check for I/O errors WRITHE1A.204
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(101))THEN WRITHE1A.205
CALL IOERROR('buffer out of integer constants',A,LEN_IO, WRITHE1A.206
* FIXHD(101)) WRITHE1A.207
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.208
ICODE=3 WRITHE1A.209
RETURN WRITHE1A.210
ENDIF WRITHE1A.211
WRITHE1A.212
START_BLOCK=START_BLOCK+FIXHD(101) WRITHE1A.213
WRITHE1A.214
ENDIF WRITHE1A.215
WRITHE1A.216
CL 3. Buffer out real constants WRITHE1A.217
WRITHE1A.218
IF(FIXHD(105).GT.0)THEN WRITHE1A.219
WRITHE1A.220
*IF DEF,DIAG81 WRITHE1A.221
C Check for error in file pointers WRITHE1A.222
IF(FIXHD(105).NE.START_BLOCK)THEN WRITHE1A.223
CALL POSERROR('real constants',START_BLOCK,105,FIXHD(105)) WRITHE1A.224
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.225
ICODE=4 WRITHE1A.226
RETURN WRITHE1A.227
ENDIF WRITHE1A.228
*ENDIF WRITHE1A.229
WRITHE1A.230
C Check for I/O errors WRITHE1A.231
*IF DEF,IEEE WRITHE1A.232
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.233
I= CRI2IEG(3,FIXHD(106),REALHD_OUT,0,REALHD,1,64,IEEE_TYPE) UDG1F402.46
CALL BUFFO32(NFTOUT,REALHD_OUT,FIXHD(106),LEN_IO,A) WRITHE1A.235
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.236
IF(LPVP)THEN UDG2F404.106
I= CRI2CRAY(2,FIXHD(106),REALHD_OUT,0,REALHD,1) UDG2F404.107
ELSE UDG2F404.108
I= CRAY2CRI(2,FIXHD(106),REALHD,0,REALHD_OUT,1) UDG2F404.109
END IF UDG2F404.110
CALL BUFFOUT(NFTOUT,REALHD_OUT,FIXHD(106),LEN_IO,A) WRITHE1A.238
ENDIF WRITHE1A.239
*ELSE WRITHE1A.240
CALL BUFFOUT(NFTOUT,REALHD(1),FIXHD(106),LEN_IO,A) WRITHE1A.241
*ENDIF WRITHE1A.242
WRITHE1A.243
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(106))THEN WRITHE1A.244
CALL IOERROR('buffer out of real constants',A,LEN_IO, WRITHE1A.245
* FIXHD(106)) WRITHE1A.246
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.247
ICODE=5 WRITHE1A.248
RETURN WRITHE1A.249
ENDIF WRITHE1A.250
WRITHE1A.251
START_BLOCK=START_BLOCK+FIXHD(106) WRITHE1A.252
WRITHE1A.253
ENDIF WRITHE1A.254
WRITHE1A.255
CL 4. Buffer out level dependent constants WRITHE1A.256
WRITHE1A.257
IF(FIXHD(110).GT.0)THEN WRITHE1A.258
WRITHE1A.259
*IF DEF,DIAG81 WRITHE1A.260
C Check for error in file pointers WRITHE1A.261
IF(FIXHD(110).NE.START_BLOCK)THEN WRITHE1A.262
CALL POSERROR('level dependent constants', WRITHE1A.263
* START_BLOCK,110,FIXHD(110)) WRITHE1A.264
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.265
ICODE=6 WRITHE1A.266
RETURN WRITHE1A.267
ENDIF WRITHE1A.268
*ENDIF WRITHE1A.269
WRITHE1A.270
*IF DEF,IEEE WRITHE1A.271
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.272
I= CRI2IEG(3,FIXHD(111)*FIXHD(112),LEVDEPC_OUT,0, UDG1F402.48
& LEVDEPC,1,64,IEEE_TYPE) UDG1F402.49
CALL BUFFO32(NFTOUT,LEVDEPC_OUT,FIXHD(111)*FIXHD(112),LEN_IO,A) WRITHE1A.274
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.275
IF(LPVP)THEN UDG2F404.111
I= CRI2CRAY(2,FIXHD(111)*FIXHD(112),LEVDEPC_OUT,0,LEVDEPC,1) UDG2F404.112
ELSE UDG2F404.113
I= CRAY2CRI(2,FIXHD(111)*FIXHD(112),LEVDEPC,0,LEVDEPC_OUT,1) UDG2F404.114
END IF UDG2F404.115
CALL BUFFOUT(NFTOUT,LEVDEPC_OUT,FIXHD(111)*FIXHD(112),LEN_IO,A) WRITHE1A.277
ENDIF WRITHE1A.278
*ELSE WRITHE1A.279
CALL BUFFOUT(NFTOUT,LEVDEPC(1),FIXHD(111)*FIXHD(112),LEN_IO,A) WRITHE1A.280
*ENDIF WRITHE1A.281
WRITHE1A.282
C Check for I/O errors WRITHE1A.283
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(111)*FIXHD(112))THEN WRITHE1A.284
CALL IOERROR('buffer out of level dependent constants',A,LEN_IO, WRITHE1A.285
* FIXHD(111)*FIXHD(112)) WRITHE1A.286
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.287
ICODE=7 WRITHE1A.288
RETURN WRITHE1A.289
ENDIF WRITHE1A.290
WRITHE1A.291
START_BLOCK=START_BLOCK+FIXHD(111)*FIXHD(112) WRITHE1A.292
WRITHE1A.293
*IF DEF,MPP GPB0F305.430
IF (mype .EQ. 0) THEN GPB0F305.431
*ENDIF GPB0F305.432
WRITE(6,'('' '')') WRITHE1A.294
WRITE(6,'('' LEVEL DEPENDENT CONSTANTS'')') WRITHE1A.295
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(111)*FIXHD(112) WRITHE1A.296
*IF DEF,MPP GPB0F305.433
ENDIF ! if mype .eq. 0 GPB0F305.434
*ENDIF GPB0F305.435
WRITHE1A.297
ENDIF WRITHE1A.298
WRITHE1A.299
CL 5. Buffer out row dependent constants WRITHE1A.300
WRITHE1A.301
IF(FIXHD(115).GT.0)THEN WRITHE1A.302
WRITHE1A.303
*IF DEF,DIAG81 WRITHE1A.304
C Check for error in file pointers WRITHE1A.305
IF(FIXHD(115).NE.START_BLOCK)THEN WRITHE1A.306
CALL POSERROR('row dependent constants', WRITHE1A.307
* START_BLOCK,115,FIXHD(115)) WRITHE1A.308
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.309
ICODE=8 WRITHE1A.310
RETURN WRITHE1A.311
ENDIF WRITHE1A.312
*ENDIF WRITHE1A.313
WRITHE1A.314
*IF DEF,IEEE WRITHE1A.315
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.316
I= CRI2IEG(3,FIXHD(116)*FIXHD(117),ROWDEPC_OUT,0, UDG1F402.51
& ROWDEPC,1,64,IEEE_TYPE) UDG1F402.52
CALL BUFFO32(NFTOUT,ROWDEPC_OUT,FIXHD(116)*FIXHD(117),LEN_IO,A) WRITHE1A.318
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.319
IF(LPVP)THEN UDG2F404.116
I= CRI2CRAY(2,FIXHD(116)*FIXHD(117),ROWDEPC_OUT,0,ROWDEPC,1) UDG2F404.117
ELSE UDG2F404.118
I= CRAY2CRI(2,FIXHD(116)*FIXHD(117),ROWDEPC,0,ROWDEPC_OUT,1) UDG2F404.119
END IF UDG2F404.120
CALL BUFFOUT(NFTOUT,ROWDEPC_OUT,FIXHD(116)*FIXHD(117),LEN_IO,A) WRITHE1A.321
ENDIF WRITHE1A.322
*ELSE WRITHE1A.323
CALL BUFFOUT(NFTOUT,ROWDEPC(1),FIXHD(116)*FIXHD(117),LEN_IO,A) WRITHE1A.324
*ENDIF WRITHE1A.325
WRITHE1A.326
C Check for I/O errors WRITHE1A.327
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(116)*FIXHD(117))THEN WRITHE1A.328
CALL IOERROR('buffer out of row dependent constants',A,LEN_IO, WRITHE1A.329
* FIXHD(116)*FIXHD(117)) WRITHE1A.330
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.331
ICODE=9 WRITHE1A.332
RETURN WRITHE1A.333
ENDIF WRITHE1A.334
WRITHE1A.335
WRITHE1A.336
START_BLOCK=START_BLOCK+FIXHD(116)*FIXHD(117) WRITHE1A.337
WRITHE1A.338
*IF DEF,MPP GPB0F305.436
IF (mype .EQ. 0) THEN GPB0F305.437
*ENDIF GPB0F305.438
WRITE(6,'('' '')') WRITHE1A.339
WRITE(6,'('' ROW DEPENDENT CONSTANTS'')') WRITHE1A.340
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(116)*FIXHD(117) WRITHE1A.341
*IF DEF,MPP GPB0F305.439
ENDIF ! if mype .eq. 0 GPB0F305.440
*ENDIF GPB0F305.441
WRITHE1A.342
ENDIF WRITHE1A.343
WRITHE1A.344
CL 6. Buffer out column dependent constants WRITHE1A.345
WRITHE1A.346
IF(FIXHD(120).GT.0)THEN WRITHE1A.347
WRITHE1A.348
*IF DEF,DIAG81 WRITHE1A.349
C Check for error in file pointers WRITHE1A.350
IF(FIXHD(120).NE.START_BLOCK)THEN WRITHE1A.351
CALL POSERROR('column dependent constants', WRITHE1A.352
* START_BLOCK,120,FIXHD(120)) WRITHE1A.353
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.354
ICODE=10 WRITHE1A.355
RETURN WRITHE1A.356
ENDIF WRITHE1A.357
*ENDIF WRITHE1A.358
WRITHE1A.359
*IF DEF,IEEE WRITHE1A.360
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.361
I= CRI2IEG(3,FIXHD(121)*FIXHD(122),COLDEPC_OUT,0, UDG1F402.54
& COLDEPC,1,64,IEEE_TYPE) UDG1F402.55
CALL BUFFO32(NFTOUT,COLDEPC_OUT,FIXHD(121)*FIXHD(122),LEN_IO,A) WRITHE1A.363
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.364
IF(LPVP)THEN UDG2F404.121
I= CRI2CRAY(2,FIXHD(121)*FIXHD(122),COLDEPC_OUT,0,COLDEPC,1) UDG2F404.122
ELSE UDG2F404.123
I= CRAY2CRI(2,FIXHD(121)*FIXHD(122),COLDEPC,0,COLDEPC_OUT,1) UDG2F404.124
END IF UDG2F404.125
CALL BUFFOUT(NFTOUT,COLDEPC_OUT,FIXHD(121)*FIXHD(122),LEN_IO,A) WRITHE1A.366
ENDIF WRITHE1A.367
*ELSE WRITHE1A.368
CALL BUFFOUT(NFTOUT,COLDEPC(1),FIXHD(121)*FIXHD(122),LEN_IO,A) WRITHE1A.369
*ENDIF WRITHE1A.370
WRITHE1A.371
C Check for I/O errors WRITHE1A.372
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(121)*FIXHD(122))THEN WRITHE1A.373
CALL IOERROR('buffer out of column dependent constants',A,LEN_IO WRITHE1A.374
* ,FIXHD(121)*FIXHD(122)) WRITHE1A.375
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.376
ICODE=11 WRITHE1A.377
RETURN WRITHE1A.378
ENDIF WRITHE1A.379
WRITHE1A.380
START_BLOCK=START_BLOCK+FIXHD(121)*FIXHD(122) WRITHE1A.381
WRITHE1A.382
*IF DEF,MPP GPB0F305.442
IF (mype .EQ. 0) THEN GPB0F305.443
*ENDIF GPB0F305.444
WRITE(6,'('' '')') WRITHE1A.383
WRITE(6,'('' COLUMN DEPENDENT CONSTANTS'')') WRITHE1A.384
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(121)*FIXHD(122) WRITHE1A.385
*IF DEF,MPP GPB0F305.445
ENDIF ! if mype .eq. 0 GPB0F305.446
*ENDIF GPB0F305.447
WRITHE1A.386
ENDIF WRITHE1A.387
WRITHE1A.388
CL 7. Buffer out constants stored as fields WRITHE1A.389
WRITHE1A.390
IF(FIXHD(125).GT.0)THEN WRITHE1A.391
WRITHE1A.392
*IF DEF,DIAG81 WRITHE1A.393
C Check for error in file pointers WRITHE1A.394
IF(FIXHD(125).NE.START_BLOCK)THEN WRITHE1A.395
CALL POSERROR('fields of constants', WRITHE1A.396
* START_BLOCK,125,FIXHD(125)) WRITHE1A.397
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.398
ICODE=12 WRITHE1A.399
RETURN WRITHE1A.400
ENDIF WRITHE1A.401
*ENDIF WRITHE1A.402
WRITHE1A.403
*IF DEF,IEEE WRITHE1A.404
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.405
I= CRI2IEG(3,FIXHD(126)*FIXHD(127),FLDDEPC_OUT,0, UDG1F402.57
& FLDDEPC,1,64,IEEE_TYPE) UDG1F402.58
CALL BUFFO32(NFTOUT,FLDDEPC_OUT,FIXHD(126)*FIXHD(127),LEN_IO,A) WRITHE1A.407
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.408
IF(LPVP)THEN UDG2F404.126
I= CRI2CRAY(2,FIXHD(126)*FIXHD(127),FLDDEPC_OUT,0,FLDDEPC,1) UDG2F404.127
ELSE UDG2F404.128
I= CRAY2CRI(2,FIXHD(126)*FIXHD(127),FLDDEPC,0,FLDDEPC_OUT,1) UDG2F404.129
END IF UDG2F404.130
CALL BUFFOUT(NFTOUT,FLDDEPC_OUT,FIXHD(126)*FIXHD(127),LEN_IO,A) WRITHE1A.410
ENDIF WRITHE1A.411
*ELSE WRITHE1A.412
CALL BUFFOUT(NFTOUT,FLDDEPC(1),FIXHD(126)*FIXHD(127),LEN_IO,A) WRITHE1A.413
*ENDIF WRITHE1A.414
WRITHE1A.415
C Check for I/O errors WRITHE1A.416
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(126)*FIXHD(127))THEN WRITHE1A.417
CALL IOERROR('buffer out of field dependent constants',A,LEN_IO, WRITHE1A.418
* FIXHD(126)*FIXHD(127)) WRITHE1A.419
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.420
ICODE=13 WRITHE1A.421
RETURN WRITHE1A.422
ENDIF WRITHE1A.423
WRITHE1A.424
START_BLOCK=START_BLOCK+FIXHD(126)*FIXHD(127) WRITHE1A.425
WRITHE1A.426
*IF DEF,MPP GPB0F305.448
IF (mype .EQ. 0) THEN GPB0F305.449
*ENDIF GPB0F305.450
WRITE(6,'('' '')') WRITHE1A.427
WRITE(6,'('' FIELD DEPENDENT CONSTANTS'')') WRITHE1A.428
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(126)*FIXHD(127) WRITHE1A.429
*IF DEF,MPP GPB0F305.451
ENDIF ! if mype .eq. 0 GPB0F305.452
*ENDIF GPB0F305.453
WRITHE1A.430
ENDIF WRITHE1A.431
WRITHE1A.432
CL 8. Buffer out extra constants WRITHE1A.433
WRITHE1A.434
IF(FIXHD(130).GT.0)THEN WRITHE1A.435
WRITHE1A.436
*IF DEF,DIAG81 WRITHE1A.437
C Check for error in file pointers WRITHE1A.438
IF(FIXHD(130).NE.START_BLOCK)THEN WRITHE1A.439
CALL POSERROR('extra constants', WRITHE1A.440
* START_BLOCK,130,FIXHD(130)) WRITHE1A.441
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.442
ICODE=14 WRITHE1A.443
RETURN WRITHE1A.444
ENDIF WRITHE1A.445
*ENDIF WRITHE1A.446
WRITHE1A.447
*IF DEF,IEEE WRITHE1A.448
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.449
I= CRI2IEG(3,FIXHD(131),EXTCNST_OUT,0,EXTCNST,1,64,IEEE_TYPE) UDG1F402.60
CALL BUFFO32(NFTOUT,EXTCNST_OUT,FIXHD(131),LEN_IO,A) WRITHE1A.451
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.452
IF(LPVP)THEN UDG2F404.131
I= CRI2CRAY(2,FIXHD(131),EXTCNST_OUT,0,EXTCNST,1) UDG2F404.132
ELSE UDG2F404.133
I= CRAY2CRI(2,FIXHD(131),EXTCNST,0,EXTCNST_OUT,1) UDG2F404.134
END IF UDG2F404.135
CALL BUFFOUT(NFTOUT,EXTCNST_OUT,FIXHD(131),LEN_IO,A) WRITHE1A.454
ENDIF WRITHE1A.455
*ELSE WRITHE1A.456
CALL BUFFOUT(NFTOUT,EXTCNST(1),FIXHD(131),LEN_IO,A) WRITHE1A.457
*ENDIF WRITHE1A.458
WRITHE1A.459
C Check for I/O errors WRITHE1A.460
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(131))THEN WRITHE1A.461
CALL IOERROR('buffer out extra constants',A,LEN_IO, WRITHE1A.462
* FIXHD(131)) WRITHE1A.463
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.464
ICODE=15 WRITHE1A.465
RETURN WRITHE1A.466
ENDIF WRITHE1A.467
WRITHE1A.468
START_BLOCK=START_BLOCK+FIXHD(131) WRITHE1A.469
WRITHE1A.470
*IF DEF,MPP GPB0F305.454
IF (mype .EQ. 0) THEN GPB0F305.455
*ENDIF GPB0F305.456
WRITE(6,'('' '')') WRITHE1A.471
WRITE(6,'('' EXTRA CONSTANTS'')') WRITHE1A.472
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(131) WRITHE1A.473
*IF DEF,MPP GPB0F305.457
ENDIF ! if mype .eq. 0 GPB0F305.458
*ENDIF GPB0F305.459
WRITHE1A.474
ENDIF WRITHE1A.475
WRITHE1A.476
CL 9. Buffer out temporary history block WRITHE1A.477
WRITHE1A.478
IF(FIXHD(135).GT.0)THEN WRITHE1A.479
WRITHE1A.480
*IF DEF,DIAG81 WRITHE1A.481
C Check for error in file pointers WRITHE1A.482
IF(FIXHD(135).NE.START_BLOCK)THEN WRITHE1A.483
CALL POSERROR('history', WRITHE1A.484
* START_BLOCK,136,FIXHD(136)) WRITHE1A.485
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.486
ICODE=16 WRITHE1A.487
RETURN WRITHE1A.488
ENDIF WRITHE1A.489
*ENDIF WRITHE1A.490
WRITHE1A.491
*IF DEF,IEEE WRITHE1A.492
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.493
I= CRI2IEG(3,FIXHD(136),DUMPHIST_OUT,0,DUMPHIST,1,64,IEEE_TYPE) UDG1F402.62
CALL BUFFO32(NFTOUT,DUMPHIST_OUT,FIXHD(136),LEN_IO,A) WRITHE1A.495
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.496
IF(LPVP)THEN UDG2F404.136
I= CRI2CRAY(2,FIXHD(136),DUMPHIST_OUT,0,DUMPHIST,1) UDG2F404.137
ELSE UDG2F404.138
I= CRAY2CRI(2,FIXHD(136),DUMPHIST,0,DUMPHIST_OUT,1) UDG2F404.139
END IF UDG2F404.140
CALL BUFFOUT(NFTOUT,DUMPHIST_OUT,FIXHD(136),LEN_IO,A) WRITHE1A.498
ENDIF WRITHE1A.499
*ELSE WRITHE1A.500
CALL BUFFOUT(NFTOUT,DUMPHIST(1),FIXHD(136),LEN_IO,A) WRITHE1A.501
*ENDIF WRITHE1A.502
WRITHE1A.503
C Check for I/O errors WRITHE1A.504
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(136))THEN WRITHE1A.505
CALL IOERROR('buffer out of history file',A,LEN_IO, WRITHE1A.506
* FIXHD(136)) WRITHE1A.507
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.508
ICODE=17 WRITHE1A.509
RETURN WRITHE1A.510
ENDIF WRITHE1A.511
WRITHE1A.512
START_BLOCK=START_BLOCK+FIXHD(136) WRITHE1A.513
WRITHE1A.514
*IF DEF,MPP GPB0F305.460
IF (mype .EQ. 0) THEN GPB0F305.461
*ENDIF GPB0F305.462
WRITE(6,'('' '')') WRITHE1A.515
WRITE(6,'('' TEMPORARY HISTORY BLOCK'')') WRITHE1A.516
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(136) WRITHE1A.517
*IF DEF,MPP GPB0F305.463
ENDIF ! if mype .eq. 0 GPB0F305.464
*ENDIF GPB0F305.465
WRITHE1A.518
ENDIF WRITHE1A.519
WRITHE1A.520
CL 10. Buffer out compressed field index1 WRITHE1A.521
WRITHE1A.522
IF(FIXHD(140).GT.0)THEN WRITHE1A.523
WRITHE1A.524
*IF DEF,DIAG81 WRITHE1A.525
C Check for error in file pointers WRITHE1A.526
WRITHE1A.527
IF(FIXHD(140).NE.START_BLOCK)THEN WRITHE1A.528
CALL POSERROR('compressed field index1', WRITHE1A.529
* START_BLOCK,140,FIXHD(140)) WRITHE1A.530
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.531
ICODE=18 WRITHE1A.532
RETURN WRITHE1A.533
ENDIF WRITHE1A.534
*ENDIF WRITHE1A.535
WRITHE1A.536
WRITHE1A.537
*IF DEF,IEEE WRITHE1A.538
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.539
I= CRI2IEG(2,FIXHD(141),CFI1_OUT,0,CFI1,1,64,IEEE_TYPE) UDG1F402.64
CALL BUFFO32(NFTOUT,CFI1_OUT,FIXHD(141),LEN_IO,A) WRITHE1A.541
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.542
CALL BUFFOUT(NFTOUT,CFI1(1),FIXHD(141),LEN_IO,A) WRITHE1A.543
ENDIF WRITHE1A.544
*ELSE WRITHE1A.545
CALL BUFFOUT(NFTOUT,CFI1(1),FIXHD(141),LEN_IO,A) WRITHE1A.546
*ENDIF WRITHE1A.547
WRITHE1A.548
C Check for I/O errors WRITHE1A.549
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(141))THEN WRITHE1A.550
CALL IOERROR('buffer out of compressed index1',A,LEN_IO, WRITHE1A.551
* FIXHD(141)) WRITHE1A.552
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.553
ICODE=19 WRITHE1A.554
RETURN WRITHE1A.555
ENDIF WRITHE1A.556
WRITHE1A.557
START_BLOCK=START_BLOCK+FIXHD(141) WRITHE1A.558
WRITHE1A.559
*IF DEF,MPP GPB0F305.466
IF (mype .EQ. 0) THEN GPB0F305.467
*ENDIF GPB0F305.468
WRITE(6,'('' '')') WRITHE1A.560
WRITE(6,'('' COMPRESSED FIELD INDEX NO 1'')') WRITHE1A.561
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(141) WRITHE1A.562
*IF DEF,MPP GPB0F305.469
ENDIF ! if mype .eq. 0 GPB0F305.470
*ENDIF GPB0F305.471
WRITHE1A.563
ENDIF WRITHE1A.564
WRITHE1A.565
CL 11. Buffer out compressed field index2 WRITHE1A.566
WRITHE1A.567
IF(FIXHD(142).GT.0)THEN WRITHE1A.568
WRITHE1A.569
*IF DEF,DIAG81 WRITHE1A.570
C Check for error in file pointers WRITHE1A.571
IF(FIXHD(142).NE.START_BLOCK)THEN WRITHE1A.572
CALL POSERROR('compressed field index2', WRITHE1A.573
* START_BLOCK,142,FIXHD(142)) WRITHE1A.574
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.575
ICODE=20 WRITHE1A.576
RETURN WRITHE1A.577
ENDIF WRITHE1A.578
*ENDIF WRITHE1A.579
WRITHE1A.580
*IF DEF,IEEE WRITHE1A.581
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.582
I= CRI2IEG(2,FIXHD(143),CFI2_OUT,0,CFI2,1,64,IEEE_TYPE) UDG1F402.65
CALL BUFFO32(NFTOUT,CFI2_OUT,FIXHD(143),LEN_IO,A) WRITHE1A.584
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.585
CALL BUFFOUT(NFTOUT,CFI2(1),FIXHD(143),LEN_IO,A) WRITHE1A.586
ENDIF WRITHE1A.587
*ELSE WRITHE1A.588
CALL BUFFOUT(NFTOUT,CFI2(1),FIXHD(143),LEN_IO,A) WRITHE1A.589
*ENDIF WRITHE1A.590
WRITHE1A.591
C Check for I/O errors WRITHE1A.592
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(143))THEN WRITHE1A.593
CALL IOERROR('buffer out of compressed index2',A,LEN_IO, WRITHE1A.594
* FIXHD(143)) WRITHE1A.595
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.596
ICODE=21 WRITHE1A.597
RETURN WRITHE1A.598
ENDIF WRITHE1A.599
WRITHE1A.600
START_BLOCK=START_BLOCK+FIXHD(143) WRITHE1A.601
WRITHE1A.602
*IF DEF,MPP GPB0F305.472
IF (mype .EQ. 0) THEN GPB0F305.473
*ENDIF GPB0F305.474
WRITE(6,'('' '')') WRITHE1A.603
WRITE(6,'('' COMPRESSED FIELD INDEX NO 2'')') WRITHE1A.604
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(143) WRITHE1A.605
*IF DEF,MPP GPB0F305.475
ENDIF ! if mype .eq. 0 GPB0F305.476
*ENDIF GPB0F305.477
WRITHE1A.606
ENDIF WRITHE1A.607
WRITHE1A.608
CL 12. Buffer out compressed field index3 WRITHE1A.609
WRITHE1A.610
IF(FIXHD(144).GT.0)THEN WRITHE1A.611
WRITHE1A.612
*IF DEF,DIAG81 WRITHE1A.613
C Check for error in file pointers WRITHE1A.614
IF(FIXHD(144).NE.START_BLOCK)THEN WRITHE1A.615
CALL POSERROR('compressed field index3', WRITHE1A.616
* START_BLOCK,144,FIXHD(144)) WRITHE1A.617
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.618
ICODE=22 WRITHE1A.619
RETURN WRITHE1A.620
ENDIF WRITHE1A.621
*ENDIF WRITHE1A.622
WRITHE1A.623
*IF DEF,IEEE WRITHE1A.624
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.625
I= CRI2IEG(2,FIXHD(145),CFI3_OUT,0,CFI3,1,64,IEEE_TYPE) UDG1F402.66
CALL BUFFO32(NFTOUT,CFI3_OUT,FIXHD(145),LEN_IO,A) WRITHE1A.627
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.628
CALL BUFFOUT(NFTOUT,CFI3(1),FIXHD(145),LEN_IO,A) WRITHE1A.629
ENDIF WRITHE1A.630
*ELSE WRITHE1A.631
CALL BUFFOUT(NFTOUT,CFI3(1),FIXHD(145),LEN_IO,A) WRITHE1A.632
*ENDIF WRITHE1A.633
WRITHE1A.634
C Check for I/O errors WRITHE1A.635
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(145))THEN WRITHE1A.636
CALL IOERROR('buffer out of compressed index3',A,LEN_IO, WRITHE1A.637
* FIXHD(145)) WRITHE1A.638
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.639
ICODE=23 WRITHE1A.640
RETURN WRITHE1A.641
ENDIF WRITHE1A.642
WRITHE1A.643
START_BLOCK=START_BLOCK+FIXHD(145) WRITHE1A.644
WRITHE1A.645
*IF DEF,MPP GPB0F305.478
IF (mype .EQ. 0) THEN GPB0F305.479
*ENDIF GPB0F305.480
WRITE(6,'('' '')') WRITHE1A.646
WRITE(6,'('' COMPRESSED FIELD INDEX NO 3'')') WRITHE1A.647
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(145) WRITHE1A.648
*IF DEF,MPP GPB0F305.481
ENDIF ! if mype .eq. 0 GPB0F305.482
*ENDIF GPB0F305.483
WRITHE1A.649
ENDIF WRITHE1A.650
WRITHE1A.651
CL 13. Buffer out lookup table WRITHE1A.652
WRITHE1A.653
IF(FIXHD(150).GT.0)THEN WRITHE1A.654
*IF DEF,IEEE UBC0F402.1
c UBC0F402.2
if(start_block.ne.fixhd(150)) then UBC0F402.3
if(start_block.gt.fixhd(150)) then UBC0F402.4
write(6,9975) start_block-1, fixhd(150)-1 UBC0F402.5
9975 format(/ UBC0F402.6
2 10(/'**** ERROR - Current Disk Address is greater than', UBC0F402.7
3 ' the Address in the Fixed Length Header for the', UBC0F402.8
4 ' Lookup Table *****')) UBC0F402.9
call abort('CONVIEEE: Fixed length Header Error') UBC0F402.10
else UBC0F402.11
write(6,9976) start_block-1, fixhd(150)-1 UBC0F402.12
9976 format( UBC0F402.13
2 10(/'**** WARNING - Current Disk Address does not match', UBC0F402.14
3 ' the Address in the Fixed Length Header for the', UBC0F402.15
4 ' Lookup Table *****')// UBC0F402.16
5 'Current Address altered from ',i10,' to ',i10, UBC0F402.17
6 ' to match the Fixed Length Header'/) UBC0F402.18
start_block=fixhd(150) UBC0F402.19
if(ieee_type.eq.32) then UBC0F402.20
call setpos32(nftout, start_block-1, j) UBC0F402.21
else UBC0F402.22
call setpos(nftout, start_block-1, j) UBC0F402.23
endif UBC0F402.24
endif UBC0F402.25
endif UBC0F402.26
*ENDIF UBC0F402.27
WRITHE1A.655
*IF DEF,DIAG81 WRITHE1A.656
C Check for error in file pointers WRITHE1A.657
IF(FIXHD(150).NE.START_BLOCK)THEN WRITHE1A.658
CALL POSERROR('lookup table', WRITHE1A.659
* START_BLOCK,150,FIXHD(150)) WRITHE1A.660
CMESSAGE='WRITHEAD: Addressing conflict' WRITHE1A.661
ICODE=24 WRITHE1A.662
RETURN WRITHE1A.663
ENDIF WRITHE1A.664
*ENDIF WRITHE1A.665
WRITHE1A.666
*IF DEF,IEEE WRITHE1A.667
IF(IEEE_TYPE.EQ.32)THEN WRITHE1A.668
DO I=1,FIXHD(152) WRITHE1A.669
J= CRI2IEG(2,45,LOOKUP_O32(1,I),0,LOOKUP(1,I),1,64,IEEE_TYPE) UDG1F402.67
J= CRI2IEG(3,19,LOOKUP_O32(23,I),32,LOOKUP(46,I),1,64,IEEE_TYPE) UDG1F402.68
IF (FIXHD(5).EQ.6.OR.FIXHD(5).EQ.7.OR. ! 6=ACOBS 7=VAROBS UDG1F405.1291
& FIXHD(5).EQ.8.OR.FIXHD(5).EQ.10)THEN ! 8=CX 10=OBSTORE UDG1F405.1292
J=CRI2IEG(2,64,LOOKUP_O32(33,I),0,LOOKUP(65,I), UDG1F402.69
& 1,64,IEEE_TYPE) UDG1F402.70
ENDIF UTS0F400.5
ENDDO WRITHE1A.672
CALL BUFFO32(NFTOUT,LOOKUP_O32,FIXHD(151)*FIXHD(152),LEN_IO,A) WRITHE1A.673
ELSEIF(IEEE_TYPE.EQ.64)THEN WRITHE1A.674
DO I=1,FIXHD(152) WRITHE1A.675
IF(LPVP)THEN UDG2F404.141
J= CRI2CRAY(0,45,LOOKUP_O64(1,I),0,LOOKUP(1,I),1) UDG2F404.142
J= CRI2CRAY(2,19,LOOKUP_O64(46,I),0,LOOKUP(46,I),1) UDG2F404.143
ELSE UDG2F404.144
J= CRAY2CRI(0,45,LOOKUP(1,I),0,LOOKUP_O64(1,I),1) UDG2F404.145
J= CRAY2CRI(2,19,LOOKUP(46,I),0,LOOKUP_O64(46,I),1) UDG2F404.146
END IF UDG2F404.147
IF (FIXHD(5).EQ.6.OR.FIXHD(5).EQ.7.OR. ! 6=ACOBS 7=VAROBS UDG1F405.1293
& FIXHD(5).EQ.8.OR.FIXHD(5).EQ.10)THEN ! 8=CX 10=OBSTORE UDG1F405.1294
IF(LPVP)THEN UDG2F404.148
J= CRI2CRAY(0,64,LOOKUP_O64(65,I),0,LOOKUP(65,I),1) UDG2F404.149
ELSE UDG2F404.150
J= CRAY2CRI(0,64,LOOKUP(65,I),0,LOOKUP_O64(65,I),1) UDG2F404.151
END IF UDG2F404.152
ENDIF UTS0F400.8
ENDDO WRITHE1A.678
CALL BUFFOUT(NFTOUT,LOOKUP_O64,FIXHD(151)*FIXHD(152),LEN_IO,A) WRITHE1A.679
ENDIF WRITHE1A.680
*ELSE WRITHE1A.681
CALL BUFFOUT(NFTOUT,LOOKUP(1,1),FIXHD(151)*FIXHD(152),LEN_IO,A) WRITHE1A.682
*ENDIF WRITHE1A.683
WRITHE1A.684
C Check for I/O errors WRITHE1A.685
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(151)*FIXHD(152))THEN WRITHE1A.686
CALL IOERROR('buffer out of lookup table',A,LEN_IO, WRITHE1A.687
* FIXHD(151)*FIXHD(152)) WRITHE1A.688
CMESSAGE='WRITHEAD: I/O error' WRITHE1A.689
ICODE=25 WRITHE1A.690
RETURN WRITHE1A.691
ENDIF WRITHE1A.692
WRITHE1A.693
START_BLOCK=START_BLOCK+FIXHD(151)*FIXHD(152) WRITHE1A.694
WRITHE1A.695
*IF DEF,MPP GPB0F305.484
IF (mype .EQ. 0) THEN GPB0F305.485
*ENDIF GPB0F305.486
WRITE(6,'('' '')') WRITHE1A.696
WRITE(6,'('' LOOKUP TABLE'')') WRITHE1A.697
WRITE(6,'('' '',I8,'' 64-bit words long'')')FIXHD(151)*FIXHD(152) WRITHE1A.698
*IF DEF,MPP GPB0F305.487
ENDIF ! if mype .eq. 0 GPB0F305.488
*ENDIF GPB0F305.489
WRITHE1A.699
*IF -DEF,MPP GPB0F305.490
C Check LOOKUP for consistency with PARAMETER statements WRITHE1A.700
CALL CHK_LOOK(FIXHD,LOOKUP,LEN1_LOOKUP,LEN_DATA, GDG0F401.1663
*CALL ARGPPX GDG0F401.1664
& ICODE,CMESSAGE) GDG0F401.1665
GDG0F401.1666
*ELSE GPB0F305.491
C No consistency checks for parallel code. The LOOKUP headers don't GPB0F305.492
C match the data layout in memory within a PE. GPB0F305.493
*ENDIF GPB0F305.494
WRITHE1A.703
ENDIF WRITHE1A.704
WRITHE1A.705
RETURN WRITHE1A.706
END WRITHE1A.707
*ENDIF WRITHE1A.708