SUBROUTINE INANCILW 1,17INANCW1A.51
& (LEN_FIXHD,LEN_INTHD,LEN_REALHD,LEN1_LEVDEPC,LEN2_LEVDEPC, INANCW1A.52
& FIXHD,INTHD,REALHD,LOOKUP,W_FIXHD,W_REALHD,W_LEVDEPC, INANCW1A.53
& NDATASETS,NLOOKUPS,FTNANCIL,LOOKUP_START,LEN1_LOOKUP, INANCW1A.54
& ROW_LENGTH,P_ROWS, INANCW1A.55
& SI,SILEN,ANCILLARY_STEPS,STEPS_PER_HR, INANCW1A.56
*CALL ARGPPX 
INANCW1A.57
& ICODE,CMESSAGE,LCAL360) INANCW1A.58
INANCW1A.59
IMPLICIT NONE INANCW1A.60
INANCW1A.61
LOGICAL LCAL360 ! Logical switch for 360-day calendar INANCW1A.62
INANCW1A.63
INTEGER INANCW1A.64
& LEN_FIXHD, ! Length of header blocks in ancillary INANCW1A.65
C ! data sets INANCW1A.66
& LEN_INTHD, ! INANCW1A.67
& LEN_REALHD, ! INANCW1A.68
& LEN1_LEVDEPC, ! Dimension of LEVDEPC in model INANCW1A.69
& LEN2_LEVDEPC INANCW1A.70
INANCW1A.71
& ,ANCILLARY_STEPS, INANCW1A.72
& STEPS_PER_HR INANCW1A.73
INANCW1A.74
INTEGER INANCW1A.75
& NDATASETS, ! No of physical files INANCW1A.76
& NLOOKUPS, ! No of lookups required(set by User I.) INANCW1A.77
& IOUNIT, INANCW1A.78
& FTNANCIL(NDATASETS), ! Fortran nos of physical files INANCW1A.79
& LOOKUP_START(NDATASETS),!start of each individual lookup INANCW1A.80
C !in overall LOOKUP array INANCW1A.81
& LEN1_LOOKUP, ! Length of PP header INANCW1A.82
& ROW_LENGTH, ! Atmosphere model dimensions INANCW1A.83
& P_ROWS, ! No. of rows for pressure-type variables INANCW1A.84
& FILE_LEVELS ! Number of levels of data in files INANCW1A.85
C ! contining multi-level data. INANCW1A.86
INANCW1A.87
& ,SILEN ! Length for SI_ATMOS/SLAB arrays INANCW1A.88
& ,SI(SILEN) ! STASHin addresses of wave INANCW1A.89
INANCW1A.90
INTEGER INANCW1A.91
& FIXHD(LEN_FIXHD,NDATASETS),! Overall Fixed header array INANCW1A.92
& W_FIXHD(LEN_FIXHD), ! Fixed header for Dump INANCW1A.93
& INTHD(LEN_INTHD,NDATASETS),! Overall Integer header array INANCW1A.94
& LOOKUP(LEN1_LOOKUP,NLOOKUPS),!Overall Lookup array INANCW1A.95
& ICODE ! Return code =0 Normal Exit INANCW1A.96
C ! >0 Error INANCW1A.97
INANCW1A.98
REAL INANCW1A.99
& REALHD(LEN_REALHD,NDATASETS),! INANCW1A.100
& W_REALHD(LEN_REALHD),! INANCW1A.101
& W_LEVDEPC(LEN1_LEVDEPC,LEN2_LEVDEPC) INANCW1A.102
CCC & ,LEVDEPC(P_LEVELS*4)! Space to hold level dependent constants INANCW1A.103
C ! from data set INANCW1A.104
INANCW1A.105
CHARACTER*80 INANCW1A.106
& CMESSAGE ! Out error message if I>0 INANCW1A.107
INANCW1A.108
*CALL CSUBMODL INANCW1A.109
*CALL CPPXREF INANCW1A.110
*CALL PPXLOOK INANCW1A.111
*CALL MODEL INANCW1A.112
*CALL CLOOKADD INANCW1A.113
*CALL CANCILW INANCW1A.114
*CALL CENVIR INANCW1A.115
INANCW1A.116
*CALL C_MDI INANCW1A.117
INANCW1A.118
! Comdecks for ancillary files/fields. INANCW1A.119
*CALL CANCFLDW INANCW1A.120
INANCW1A.121
CL External subroutines called: INANCW1A.122
INANCW1A.123
EXTERNAL INANCW1A.124
& IOERROR, ! INANCW1A.125
& PR_FIXHD, ! INANCW1A.126
& POSERROR, ! INANCW1A.127
& SETPOS, ! INANCW1A.128
& CHK_LOOK ! INANCW1A.129
INANCW1A.130
CL Namelist input INANCW1A.131
INANCW1A.132
NAMELIST/ANCILCTW/FIELDCODE INANCW1A.133
INANCW1A.134
C Local Variables INANCW1A.135
INANCW1A.136
INTEGER INANCW1A.137
& I, ! INANCW1A.138
& ITEM, ! INANCW1A.139
& J, ! INANCW1A.140
& J1, ! INANCW1A.141
& K, ! INANCW1A.142
& LEN_IO, ! INANCW1A.143
& LOOKUPS, ! INANCW1A.144
& NFTIN, ! Current FTN number for ancillary data INANCW1A.145
& START_BLOCK ! INANCW1A.146
& ,STASH_CODE ! Stash item code INANCW1A.147
& ,NREC_W ! No of wave records INANCW1A.148
& ,STASH_ADDR ! Stash address INANCW1A.149
INTEGER INANCW1A.150
& FILEANCIL_DATA(NANCIL_FIELDS) !logical file nos of each ancillary INANCW1A.151
&,STASHANCIL_DATA(NANCIL_FIELDS) ! stash item nos INANCW1A.152
INANCW1A.153
DATA INANCW1A.154
& FILEANCIL_DATA/1,1 /, INANCW1A.155
& STASHANCIL_DATA/30,33 / INANCW1A.156
INANCW1A.157
INANCW1A.158
REAL INANCW1A.159
& A_IO ! Used in test for I/O errors INANCW1A.160
C ! for checking against primar model value INANCW1A.161
INANCW1A.162
LOGICAL INANCW1A.163
& LFILE ! INANCW1A.164
INANCW1A.165
REAL P1,P2 INANCW1A.166
LOGICAL LNER INANCW1A.167
LNER(P1,P2) = ((ABS(P1-P2)) .GT. (1.E-6*ABS(P1+P2))) INANCW1A.168
INANCW1A.169
CL Internal Structure INANCW1A.170
INANCW1A.171
ICODE=0 INANCW1A.172
CMESSAGE=' ' INANCW1A.173
IOUNIT=0 INANCW1A.174
INANCW1A.175
C INANCW1A.176
CL 1. Initialisation for wave sub-model INANCW1A.177
INANCW1A.178
DO I=1,NANCIL_FIELDS INANCW1A.179
FILEANCIL(I) = ANCIL_FILE_NO(I) INANCW1A.180
STASHANCIL(I)= ITEM_CODES_ANCIL(I) INANCW1A.181
ENDDO INANCW1A.182
INANCW1A.183
CL Read in control information from namelist INANCW1A.184
INANCW1A.185
REWIND 5 INANCW1A.186
READ(5,ANCILCTW) INANCW1A.187
INANCW1A.188
! Check that ancillary field has valid address (>1) before proceding INANCW1A.189
! to try and update it. If not, switch off updating via FIELDCODE. INANCW1A.190
DO I=1,NANCIL_FIELDS INANCW1A.191
stash_addr = si(stashancil(i)) INANCW1A.192
IF (stash_addr .le. 1) THEN INANCW1A.193
IF (FIELDCODE(1,I).gt.0) THEN INANCW1A.194
WRITE(6,*)' INANCILW: update requested for item ',i, GRR1F405.31
& ' STASHcode ',stashancil(i),' but prognostic address not set' GRR1F405.32
WRITE(6,*)' FIELDCODE values reset to zeroes' GIE0F403.302
FIELDCODE(1,I) = 0 INANCW1A.198
FIELDCODE(2,I) = 0 INANCW1A.199
END IF INANCW1A.200
END IF INANCW1A.201
END DO INANCW1A.202
INANCW1A.203
CL 1.1 Set number of steps after which each ancillary field is updated INANCW1A.204
C Zero is used for fields not to be updated INANCW1A.205
INANCW1A.206
DO I=1,NANCIL_FIELDS INANCW1A.207
STEPS(I)=0 INANCW1A.208
IF (FIELDCODE(1,I).EQ.5) THEN ! new code (every n timesteps) INANCW1A.209
STEPS(I) = FIELDCODE(2,I) INANCW1A.210
END IF INANCW1A.211
IF (FIELDCODE(1,I).EQ.4)THEN INANCW1A.212
STEPS(I)=FIELDCODE(2,I)*STEPS_PER_HR INANCW1A.213
END IF INANCW1A.214
IF (FIELDCODE(1,I).EQ.3) THEN INANCW1A.215
STEPS(I)=FIELDCODE(2,I)*24*STEPS_PER_HR INANCW1A.216
END IF INANCW1A.217
INANCW1A.218
IF (LCAL360) THEN INANCW1A.219
IF (FIELDCODE(1,I).EQ.2) THEN INANCW1A.220
STEPS(I)=FIELDCODE(2,I)*30*24*STEPS_PER_HR INANCW1A.221
END IF INANCW1A.222
IF (FIELDCODE(1,I).EQ.1) THEN INANCW1A.223
STEPS(I)=FIELDCODE(2,I)*360*24*STEPS_PER_HR INANCW1A.224
END IF INANCW1A.225
ELSE INANCW1A.226
C Gregorian calender: INANCW1A.227
C If update interval is months or years, test each day. Further testing INANCW1A.228
C done in REPLANCW. INANCW1A.229
INANCW1A.230
IF (FIELDCODE(1,I).EQ.1.OR.FIELDCODE(1,I).EQ.2)THEN INANCW1A.231
STEPS(I)=24*STEPS_PER_HR INANCW1A.232
END IF INANCW1A.233
END IF INANCW1A.234
INANCW1A.235
END DO INANCW1A.236
INANCW1A.237
CL 1.2 Set master number of steps ANCILLARY_STEPS at which INANCW1A.238
CL individual switches are tested. INANCW1A.239
INANCW1A.240
C Find first active field INANCW1A.241
INANCW1A.242
DO I=1,NANCIL_FIELDS INANCW1A.243
IF (STEPS(I).GT.0) THEN INANCW1A.244
ANCILLARY_STEPS=STEPS(I) INANCW1A.245
GOTO 121 INANCW1A.246
END IF INANCW1A.247
END DO INANCW1A.248
INANCW1A.249
C No above fields found INANCW1A.250
INANCW1A.251
ANCILLARY_STEPS=0 INANCW1A.252
INANCW1A.253
GOTO 900 INANCW1A.254
121 ITEM=I INANCW1A.255
INANCW1A.256
CL Set ANCILLARY_STEPS to lowest common denominater of INANCW1A.257
CL frequencies for active fields INANCW1A.258
INANCW1A.259
DO I=ITEM+1,NANCIL_FIELDS INANCW1A.260
IF (STEPS(I).LT.ANCILLARY_STEPS INANCW1A.261
* .AND. STEPS(I).GT.0) THEN INANCW1A.262
IF (MOD(ANCILLARY_STEPS,STEPS(I)).EQ.0) THEN INANCW1A.263
ANCILLARY_STEPS=STEPS(I) INANCW1A.264
ELSE INANCW1A.265
J1=STEPS(I)-1 INANCW1A.266
DO J=J1,1,-1 INANCW1A.267
IF ((MOD(ANCILLARY_STEPS,J).EQ.0).AND. INANCW1A.268
& (MOD(STEPS(I),J).EQ.0)) THEN INANCW1A.269
GOTO 124 INANCW1A.270
ENDIF INANCW1A.271
END DO INANCW1A.272
124 ANCILLARY_STEPS = J INANCW1A.273
END IF INANCW1A.274
END IF INANCW1A.275
END DO INANCW1A.276
INANCW1A.277
CCC *ELSE INANCW1A.278
CL 1.1 Set control switches for reconfiguration (not available for INANCW1A.279
CL wave sub-model at present). INANCW1A.280
INANCW1A.281
CCC *ENDIF INANCW1A.282
INANCW1A.283
CL 1.3 Set number of headers for each ancillary field INANCW1A.284
INANCW1A.285
DO I=1,NANCIL_FIELDS INANCW1A.286
LEVELS(I)=1 INANCW1A.287
END DO INANCW1A.288
INANCW1A.289
CL 1.4 Read headers INANCW1A.290
INANCW1A.291
LOOKUPS=0 INANCW1A.292
INANCW1A.293
DO I=1,NDATASETS INANCW1A.294
INANCW1A.295
C Initialise LOOKUP_START (=0 implies file I not required) INANCW1A.296
LOOKUP_START(I)=0 INANCW1A.297
INANCW1A.298
CL Check whether each physical file is needed INANCW1A.299
INANCW1A.300
LFILE=.FALSE. INANCW1A.301
DO 141 J=1,NANCIL_FIELDS INANCW1A.302
INANCW1A.303
IF (FILEANCIL(J).EQ.I.AND.STEPS(J).GT.0) THEN INANCW1A.304
INANCW1A.305
LFILE=.TRUE. INANCW1A.306
END IF INANCW1A.307
141 CONTINUE INANCW1A.308
INANCW1A.309
IF(LFILE) THEN INANCW1A.310
INANCW1A.311
WRITE(6,*) ' ' INANCW1A.312
WRITE(6,*)' Ancillary data file ',I,',unit no ',FTNANCIL(I), INANCW1A.313
*' for forcing wind fields' INANCW1A.314
INANCW1A.315
CL Read headers for physical files required INANCW1A.316
INANCW1A.317
NFTIN=FTNANCIL(I) INANCW1A.318
INANCW1A.319
CL 1.4.1 Buffer in fixed length header record INANCW1A.320
INANCW1A.321
CALL FILE_OPEN(NFTIN,FT_ENVIRON(NFTIN), INANCW1A.322
& LEN_FT_ENVIR(NFTIN),0,0,ICODE) INANCW1A.323
IF(ICODE.NE.0)THEN INANCW1A.324
CMESSAGE='INANCLA: Error opening file' INANCW1A.325
write(6,*) 'INANCILW: Error opening file on unit ',NFTIN, GRR1F405.33
& ' accessed from env.var.: ',FT_ENVIRON(NFTIN) GRR1F405.34
RETURN INANCW1A.326
ENDIF INANCW1A.327
INANCW1A.328
CALL SETPOS(NFTIN,0,ICODE) INANCW1A.329
INANCW1A.330
CALL BUFFIN(NFTIN,FIXHD(1,I),LEN_FIXHD,LEN_IO,A_IO) INANCW1A.331
INANCW1A.332
C Check for I/O errors INANCW1A.333
INANCW1A.334
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN_FIXHD) THEN INANCW1A.335
CALL IOERROR('bufferin of fixed length header',A_IO,LEN_IO, INANCW1A.336
& LEN_FIXHD) INANCW1A.337
CMESSAGE='INANCILW:I/O error' INANCW1A.338
ICODE=1 INANCW1A.339
IOUNIT=NFTIN INANCW1A.340
RETURN INANCW1A.341
END IF INANCW1A.342
INANCW1A.343
START_BLOCK=LEN_FIXHD+1 INANCW1A.344
INANCW1A.345
C Check validity of data and print out fixed header information INANCW1A.346
INANCW1A.347
FILE_LEVELS=1 INANCW1A.348
INANCW1A.349
INANCW1A.350
CALL PR_FIXHD(FIXHD(1,I),LEN_FIXHD,LEN_INTHD, INANCW1A.351
& LEN_REALHD,FILE_LEVELS,FIXHD(112,I),FIXHD( INANCW1A.352
& 116,I),FIXHD(117,I),FIXHD(121,I),FIXHD( INANCW1A.353
& 122,I),FIXHD(126,I),FIXHD(127,I),FIXHD( INANCW1A.354
& 131,I),FIXHD(132,I),FIXHD(141,I),FIXHD(143,I), INANCW1A.355
& FIXHD(145,I),LEN1_LOOKUP,FIXHD(152,I), INANCW1A.356
& FIXHD(161,I),ICODE,CMESSAGE) INANCW1A.357
INANCW1A.358
IF(ICODE.GT.0) RETURN INANCW1A.359
INANCW1A.360
CL 1.4.2 Buffer in integer constants INANCW1A.361
INANCW1A.362
IF(FIXHD(100,I).GT.0) THEN INANCW1A.363
INANCW1A.364
C Check for error in file pointers INANCW1A.365
INANCW1A.366
IF(FIXHD(100,I).NE.START_BLOCK) THEN INANCW1A.367
CALL POSERROR('integer constants',START_BLOCK,100, INANCW1A.368
& FIXHD(100,I)) INANCW1A.369
CMESSAGE='INANCILW: Addressing conflict' INANCW1A.370
ICODE=2 INANCW1A.371
RETURN INANCW1A.372
END IF INANCW1A.373
INANCW1A.374
CALL BUFFIN(NFTIN,INTHD(1,I),FIXHD(101,I),LEN_IO,A_IO) INANCW1A.375
INANCW1A.376
C Check for I/O errors INANCW1A.377
INANCW1A.378
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.FIXHD(101,I)) THEN INANCW1A.379
CALL IOERROR('buffer in of integer constants',A_IO,LEN_IO INANCW1A.380
& ,FIXHD(101,I)) INANCW1A.381
CMESSAGE='INANCILW: I/O Error' INANCW1A.382
ICODE=3 INANCW1A.383
IOUNIT=NFTIN INANCW1A.384
RETURN INANCW1A.385
END IF INANCW1A.386
INANCW1A.387
START_BLOCK=START_BLOCK+FIXHD(101,I) INANCW1A.388
INANCW1A.389
C Check validity of integer data and print out information INANCW1A.390
C All files except ozone should contain full fields INANCW1A.391
INANCW1A.392
IF(INTHD(6,I).NE.ROW_LENGTH) THEN INANCW1A.393
ICODE=4 INANCW1A.394
CMESSAGE='INANCILW:integer header error' INANCW1A.395
WRITE(6,*) ' INTHD(6) : ',INTHD(6,I),' ??' INANCW1A.396
RETURN INANCW1A.397
END IF INANCW1A.398
INANCW1A.399
IF(INTHD(7,I).NE.P_ROWS) THEN INANCW1A.400
ICODE=5 INANCW1A.401
CMESSAGE='INANCILW:integer header error' INANCW1A.402
WRITE(6,*) ' INTHD(7) : ',INTHD(7,I),' ??' INANCW1A.403
RETURN INANCW1A.404
END IF INANCW1A.405
INANCW1A.406
END IF INANCW1A.407
INANCW1A.408
CL 1.4.3 Buffer in real constants INANCW1A.409
INANCW1A.410
IF(FIXHD(105,I).GT.0) THEN INANCW1A.411
INANCW1A.412
C Check for error in file pointers INANCW1A.413
INANCW1A.414
IF(FIXHD(105,I).NE.START_BLOCK) THEN INANCW1A.415
CALL POSERROR('integer constants',START_BLOCK,105, INANCW1A.416
& FIXHD(105,I)) INANCW1A.417
CMESSAGE='INANCILW: Addressing conflict' INANCW1A.418
ICODE=6 INANCW1A.419
RETURN INANCW1A.420
END IF INANCW1A.421
INANCW1A.422
C Check for I/O errors INANCW1A.423
INANCW1A.424
CALL BUFFIN(NFTIN,REALHD(1,I),FIXHD(106,I),LEN_IO,A_IO) INANCW1A.425
INANCW1A.426
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.FIXHD(106,I)) THEN INANCW1A.427
CALL IOERROR('buffer in of real constants',A_IO,LEN_IO, INANCW1A.428
& FIXHD(106,I)) INANCW1A.429
CMESSAGE='INANCILW: I/O Error' INANCW1A.430
ICODE=7 INANCW1A.431
IOUNIT=NFTIN INANCW1A.432
RETURN INANCW1A.433
END IF INANCW1A.434
INANCW1A.435
START_BLOCK=START_BLOCK+FIXHD(106,I) INANCW1A.436
INANCW1A.437
C Check validity of real header and print out information INANCW1A.438
INANCW1A.439
DO J=1,6 INANCW1A.440
IF(REALHD(J,I).GT.(W_REALHD(J)+0.1).OR. INANCW1A.441
& REALHD(J,I).LT.(W_REALHD(J)-0.1))THEN INANCW1A.442
IF(I.NE.1.OR.(J.NE.1.AND.J.NE.4))THEN INANCW1A.443
WRITE(6,*)(REALHD(K,I),K=1,6),(W_REALHD(K),K=1,6) INANCW1A.444
ICODE=8 INANCW1A.445
CMESSAGE='INANCILW: REAL header Error.' INANCW1A.446
RETURN INANCW1A.447
END IF INANCW1A.448
END IF INANCW1A.449
END DO INANCW1A.450
INANCW1A.451
END IF INANCW1A.452
INANCW1A.453
CL 1.4.4 Buffer in level dependent constants if required INANCW1A.454
C Not retained in model after initial check INANCW1A.455
INANCW1A.456
IF(FIXHD(110,I).GT.0) THEN INANCW1A.457
INANCW1A.458
C Check for error in file pointers INANCW1A.459
INANCW1A.460
IF(FIXHD(110,I).NE.START_BLOCK) THEN INANCW1A.461
CALL POSERROR('level dependent constants',START_BLOCK,110, INANCW1A.462
& FIXHD(110,I)) INANCW1A.463
CMESSAGE='INANCILW: Addressing conflict' INANCW1A.464
ICODE=9 INANCW1A.465
RETURN INANCW1A.466
END IF INANCW1A.467
INANCW1A.468
START_BLOCK=START_BLOCK+FIXHD(111,I)*FIXHD(112,I) INANCW1A.469
INANCW1A.470
IF(I.EQ.-1) THEN ! no multi-level wave ancillaries INANCW1A.471
INANCW1A.472
CCC CALL BUFFIN(NFTIN,LEVDEPC(1),FIXHD(111,I)*FIXHD(112,I), INANCW1A.473
CCC 1 LEN_IO,A_IO) INANCW1A.474
INANCW1A.475
C Check for I/O errors INANCW1A.476
INANCW1A.477
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.FIXHD(111,I)* INANCW1A.478
& FIXHD(112,I)) THEN INANCW1A.479
CALL IOERROR('Buffer in if level dependent constants', INANCW1A.480
& A_IO,LEN_IO,FIXHD(111,I)*FIXHD(112,I)) INANCW1A.481
CMESSAGE='INANCILW: I/O ERROR.' INANCW1A.482
ICODE=10 INANCW1A.483
IOUNIT=NFTIN INANCW1A.484
RETURN INANCW1A.485
END IF INANCW1A.486
END IF INANCW1A.487
INANCW1A.488
END IF INANCW1A.489
INANCW1A.490
CL 1.4.5 Buffer in lookup table INANCW1A.491
C Set start position of boundary fields for file INANCW1A.492
INANCW1A.493
LOOKUP_START(I)=LOOKUPS+1 INANCW1A.494
INANCW1A.495
IF(FIXHD(150,I).GT.0) THEN INANCW1A.496
INANCW1A.497
C Check for error in file pointers INANCW1A.498
INANCW1A.499
IF(FIXHD(150,I).NE.START_BLOCK) THEN INANCW1A.500
CALL POSERROR('lookup table',START_BLOCK,150, INANCW1A.501
& FIXHD(150,I)) INANCW1A.502
CMESSAGE='INANCILW: Addressing conflict' INANCW1A.503
ICODE=13 INANCW1A.504
RETURN INANCW1A.505
END IF INANCW1A.506
INANCW1A.507
IF(LOOKUPS+FIXHD(152,I).GT.NLOOKUPS) THEN INANCW1A.508
CMESSAGE='INANCILW: Insufficient space for headers' INANCW1A.509
INANCW1A.510
ICODE=14 INANCW1A.511
RETURN INANCW1A.512
END IF INANCW1A.513
INANCW1A.514
CALL BUFFIN(NFTIN,LOOKUP(1,LOOKUPS+1),FIXHD(151,I)* INANCW1A.515
1 FIXHD(152,I),LEN_IO,A_IO) INANCW1A.516
INANCW1A.517
C Check for I/O errors INANCW1A.518
INANCW1A.519
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.FIXHD(151,I)* INANCW1A.520
& FIXHD(152,I)) THEN INANCW1A.521
CALL IOERROR('buffer in of lookup table',A_IO,LEN_IO, INANCW1A.522
& FIXHD(151,I)*FIXHD(152,I)) INANCW1A.523
CMESSAGE='INANCILW: I/O Error' INANCW1A.524
ICODE=15 INANCW1A.525
IOUNIT=NFTIN INANCW1A.526
RETURN INANCW1A.527
END IF INANCW1A.528
INANCW1A.529
INANCW1A.530
C Check LOOKUP for consistency with PARAMETER statements INANCW1A.531
INANCW1A.532
CALL CHK_LOOK(FIXHD(1,I),LOOKUP(1,LOOKUPS+1),LEN1_LOOKUP, INANCW1A.533
& FIXHD(161,I), INANCW1A.534
*CALL ARGPPX INANCW1A.535
& ICODE,CMESSAGE) INANCW1A.536
INANCW1A.537
NREC_W = 0 INANCW1A.538
DO J = 1,FIXHD(152,I) INANCW1A.539
IF (LOOKUP(MODEL_CODE,LOOKUPS+J) .eq. 0 .or. INANCW1A.540
& LOOKUP(MODEL_CODE,LOOKUPS+J) .eq. imdi) THEN INANCW1A.541
STASH_CODE = LOOKUP(ITEM_CODE,LOOKUPS+J) INANCW1A.542
LOOKUP(MODEL_CODE,LOOKUPS+J) = wave_im INANCW1A.543
NREC_W = NREC_W+1 INANCW1A.544
END IF INANCW1A.545
END DO INANCW1A.546
IF (NREC_W.GT.0) THEN INANCW1A.547
WRITE (6,*) ' ' INANCW1A.548
WRITE (6,*) ' INANCILW : submodel_id in ',NREC_W, INANCW1A.549
& ' records set to wave_im in ancillary file ',I INANCW1A.550
ENDIF INANCW1A.551
INANCW1A.552
END IF INANCW1A.553
INANCW1A.554
LOOKUPS=LOOKUPS+FIXHD(152,I) INANCW1A.555
INANCW1A.556
ELSE INANCW1A.557
INANCW1A.558
CL If file not required, zero fixed length header INANCW1A.559
DO J=1,LEN_FIXHD INANCW1A.560
FIXHD(J,I)=0 INANCW1A.561
END DO INANCW1A.562
INANCW1A.563
LOOKUP_START(I)=LOOKUPS+1 INANCW1A.564
END IF INANCW1A.565
INANCW1A.566
END DO INANCW1A.567
INANCW1A.568
CL 1.5 Set positions in main data blocks INANCW1A.569
INANCW1A.570
INANCW1A.571
DO I=1,NANCIL_FIELDS INANCW1A.572
D1_ANCILADD(I)=SI(STASHANCIL(I)) INANCW1A.573
ENDDO INANCW1A.574
INANCW1A.575
CL 1.51 If a request is made to update a field, ensure that space for INANCW1A.576
CL that field has been allocted in D1. INANCW1A.577
INANCW1A.578
DO I=1,NANCIL_FIELDS INANCW1A.579
IF((FIELDCODE(1,I).GT.0).AND.(D1_ANCILADD(I).LE.1)) THEN INANCW1A.580
WRITE(6,*)' An address in D1 has not been set for ancillary INANCW1A.581
& field number ',I INANCW1A.582
ICODE=30 INANCW1A.583
CMESSAGE='INANCILW: updating for ancillary field is requested INANCW1A.584
& but space not allocated in D1' INANCW1A.585
RETURN INANCW1A.586
ENDIF INANCW1A.587
END DO INANCW1A.588
INANCW1A.589
CL 1.6 Set positions of data INANCW1A.590
INANCW1A.591
DO I=1,NANCIL_FIELDS INANCW1A.592
NLOOKUP(I) =0 INANCW1A.593
LOOKUP_STEP(I)=0 INANCW1A.594
INANCW1A.595
C If LOOKUP_START=0 for file FILEANCIL(I), no fields required. INANCW1A.596
IF (LOOKUP_START(FILEANCIL(I)).GT.0) THEN INANCW1A.597
INANCW1A.598
DO J=LOOKUP_START(FILEANCIL(I)),LOOKUPS INANCW1A.599
INANCW1A.600
IF (LOOKUP(ITEM_CODE,J).EQ.STASHANCIL(I)) THEN INANCW1A.601
NLOOKUP(I)=J-LOOKUP_START(FILEANCIL(I))+1 INANCW1A.602
GOTO 161 INANCW1A.603
END IF INANCW1A.604
INANCW1A.605
END DO INANCW1A.606
INANCW1A.607
C Find second occurrence of data to set LOOKUP_STEP INANCW1A.608
INANCW1A.609
161 LOOKUP_STEP(I)=0 INANCW1A.610
INANCW1A.611
IF(J.LT.LOOKUPS) THEN INANCW1A.612
INANCW1A.613
DO J1=J+LEVELS(I),LOOKUPS INANCW1A.614
IF (LOOKUP(ITEM_CODE,J1).EQ.STASHANCIL(I)) THEN INANCW1A.615
LOOKUP_STEP(I)=J1-NLOOKUP(I)-LOOKUP_START(FILEANCIL(I))+1 INANCW1A.616
GOTO 164 INANCW1A.617
END IF INANCW1A.618
END DO INANCW1A.619
164 CONTINUE INANCW1A.620
END IF INANCW1A.621
INANCW1A.622
END IF INANCW1A.623
INANCW1A.624
END DO INANCW1A.625
INANCW1A.626
900 CONTINUE INANCW1A.627
9999 CONTINUE INANCW1A.628
RETURN INANCW1A.629
END INANCW1A.630
*ENDIF INANCW1A.631