SUBROUTINE INANCILO 1,5INANCO1A.33
INANCO1A.34
C*L Arguments INANCO1A.35
& (LEN_FIXHD,LEN_INTHD,LEN_REALHD,LEN1_LEVDEPC, INANCO1A.36
& FIXHD,INTHD, INANCO1A.37
& REALHD,LOOKUP,O_REALHD, O_LEVDEPC, GMB1F304.8
& NDATASETS,NLOOKUPS,FTNANCIL,LOOKUP_START,LEN1_LOOKUP,IMT, INANCO1A.39
& JMT,SI,SILEN, INANCO1A.40
& ANCILLARY_STEPS,O_STEPS_P_P,O_SECS_P_P, INANCO1A.41
*CALL ARGPPX 
GDG0F401.789
& LCAL360,ICODE,CMESSAGE) ODR1F404.3
INANCO1A.43
IMPLICIT NONE INANCO1A.44
INANCO1A.45
INTEGER INANCO1A.46
& LEN_FIXHD, ! Length of header blocks in ancillary INANCO1A.47
C ! data sets INANCO1A.48
& LEN_INTHD, ! INANCO1A.49
& LEN_REALHD, ! INANCO1A.50
& LEN1_LEVDEPC, ! INANCO1A.51
& ANCILLARY_STEPS, ! INANCO1A.52
& O_STEPS_P_P, INANCO1A.53
& O_SECS_P_P INANCO1A.54
INANCO1A.55
INTEGER INANCO1A.56
& NDATASETS, ! INANCO1A.57
& NLOOKUPS, ! INANCO1A.58
& FTNANCIL(NDATASETS), INANCO1A.59
& LOOKUP_START(NDATASETS), INANCO1A.60
& LEN1_LOOKUP, ! Length of PP header INANCO1A.61
& IMT, ! Ocean model dimensions INANCO1A.62
& JMT, ! INANCO1A.63
& SILEN,SI(SILEN), ! Address pointer array and length of INANCO1A.64
C ! this array INANCO1A.65
& FIXHD(LEN_FIXHD,NDATASETS),! INANCO1A.66
& INTHD(LEN_INTHD,NDATASETS),! INANCO1A.67
& LOOKUP(LEN1_LOOKUP,NLOOKUPS), INANCO1A.68
& ICODE ! Return code =0 Normal Exit INANCO1A.69
C ! >0 Error INANCO1A.70
INANCO1A.71
REAL INANCO1A.72
& REALHD(LEN_REALHD,NDATASETS), ! GMB1F304.9
& O_REALHD(LEN_REALHD), ! GMB1F304.10
& O_LEVDEPC(LEN1_LEVDEPC) ! model level depths GMB1F304.11
INANCO1A.75
LOGICAL ODR1F404.4
& LCAL360 ! Calender Indicator (T: 360 day) ODR1F404.5
INANCO1A.76
CHARACTER*(*) INANCO1A.77
& CMESSAGE ! Out error message if I>0 INANCO1A.78
INANCO1A.79
*CALL CLOOKADD INANCO1A.80
*CALL CANCILO INANCO1A.81
*CALL CENVIR INANCO1A.82
*CALL CSUBMODL GDR7F400.52
*CALL CPPXREF GDG0F401.790
*CALL PPXLOOK GDG0F401.791
*CALL C_MDI GDR7F400.53
*CALL COCNINDX ORH7F402.291
INANCO1A.83
CL External subroutines called: INANCO1A.84
INANCO1A.85
EXTERNAL INANCO1A.86
& PR_FIXHD ODR1F404.6
&, READHEAD ODR1F404.7
&, READ_FLH ODR1F404.8
&, SETPOS GMB1F304.12
INANCO1A.92
CL Namelist input INANCO1A.93
INANCO1A.94
! UPANCO Namelist GDR6F404.43
INTEGER GDR6F404.44
& ANC_REF_NO ! Ancil Ref. No : See comdeck CANCFLDO GDR6F404.45
& ,PERIOD ! Period of Updating Interval (Y/M/D/H) GDR6F404.46
& ,INTERVAL ! Updating Interval GDR6F404.47
GDR6F404.48
NAMELIST /UPANCO/ ANC_REF_NO,PERIOD,INTERVAL GDR6F404.49
INANCO1A.96
C Local arrays GMB1F304.13
REAL LEVDEPC(LEN1_LEVDEPC) ! depths of data in ancillary file GMB1F304.14
GMB1F304.15
C Local Variables INANCO1A.97
INTEGER INANCO1A.98
& I, ! INANCO1A.99
& ITEM, ! INANCO1A.100
& J, ! INANCO1A.101
& J1, ! INANCO1A.102
& K, ! INANCO1A.103
& LEN_IO, ! INANCO1A.104
& LOOKUPS, ! INANCO1A.105
& NFTIN, ! Current FTN number for ancillary data INANCO1A.106
& START_BLOCK, ! GMB1F304.16
& O_SECS_PER_STEP, GMB1F304.17
& FILE_LEVELS ! Number of levels of data in files GMB1F304.18
C ! containing multi-level data. GMB1F304.19
& ,N_ANC_UPD ! No of ancillaries to be updated GDR6F404.50
& ,NREC_O ! No of ocean records GDR7F400.55
& ,DUMMY ODR1F404.9
ODR1F404.10
DATA DUMMY /1/ ODR1F404.11
ODR2F404.2
! Comdecks for ancillary files/fields ODR2F404.3
*CALL CANCFLDO ODR2F404.4
INANCO1A.118
CHARACTER*8 CPERIOD ! PERIOD in characters. GDR6F404.51
INANCO1A.123
LOGICAL INANCO1A.124
& LFILE ! INANCO1A.125
INANCO1A.126
CL Functions GMB1F304.20
REAL P1,P2 GMB1F304.21
LOGICAL LNER GMB1F304.22
LNER(P1,P2) = (ABS(P1-P2)) .GT. (1.E-6*ABS(P1+P2)) GMB1F304.23
INANCO1A.128
GMB1F304.24
CL---------------------------------------------------------------------- GMB1F304.25
GMB1F304.26
ICODE=0 INANCO1A.129
CMESSAGE=' ' INANCO1A.130
INANCO1A.131
CL 1 Initialisation of ocean model INANCO1A.135
INANCO1A.136
DO I=1,NANCIL_FIELDS INANCO1A.137
FILEANCIL(I)=ANCIL_FILE_NO(I) ODR2F404.5
STASHANCIL(I)=ITEM_CODES_ANCIL(I) ODR2F404.6
ENDDO INANCO1A.140
INANCO1A.141
CL Read control information from namelist INANCO1A.142
INANCO1A.143
REWIND 5 GDR6F404.52
N_ANC_UPD = 0 GDR6F404.53
DO I=1,NANCIL_FIELDS GDR6F404.54
READ (5,UPANCO,ERR=101,END=101) GDR6F404.55
FIELDCODE(1,ANC_REF_NO) = PERIOD GDR6F404.56
FIELDCODE(2,ANC_REF_NO) = INTERVAL GDR6F404.57
N_ANC_UPD = N_ANC_UPD+1 GDR6F404.58
ENDDO GDR6F404.59
GDR6F404.60
101 CONTINUE GDR6F404.61
WRITE (6,*) ' ' GDR6F404.62
WRITE (6,*) N_ANC_UPD,' Ocean Ancillaries to be updated.' GDR6F404.63
DO I=1,NANCIL_FIELDS GDR6F404.64
IF (FIELDCODE(1,I).GT.0) THEN GDR6F404.65
IF (FIELDCODE(1,I).EQ.1) CPERIOD=' Years' GDR6F404.66
IF (FIELDCODE(1,I).EQ.2) CPERIOD=' Months' GDR6F404.67
IF (FIELDCODE(1,I).EQ.3) CPERIOD=' Days' GDR6F404.68
IF (FIELDCODE(1,I).EQ.4) CPERIOD=' Hours' GDR6F404.69
WRITE (6,*) 'Anc Ref No ',I,' Stash code ', GDR6F404.70
& ITEM_CODES_ANCIL(I),' Interval ',FIELDCODE(2,I),CPERIOD GDR6F404.71
ENDIF GDR6F404.72
ENDDO GDR6F404.73
WRITE (6,*) ' ' GDR6F404.74
GDR6F404.75
INANCO1A.145
! Check that ancillary field has valid address (>1) before proceding GRB4F305.247
! to try and update it. If not, switch off updating via FIELDCODE. GRB4F305.248
DO I=1,NANCIL_FIELDS GRB4F305.249
IF (si(stashancil(i)) .le. 1) THEN GRB4F305.250
IF (FIELDCODE(1,I).gt.0) THEN GRB4F305.251
WRITE(6,*)' INANCILO: update requested for item ',i, GRR1F405.26
& ' STASHcode ',stashancil(i),' but prognostic address not set' GRR1F405.27
WRITE(6,*)' FIELDCODE values reset to zeroes' GIE0F403.291
FIELDCODE(1,I) = 0 GRB4F305.255
FIELDCODE(2,I) = 0 GRB4F305.256
END IF GRB4F305.257
END IF GRB4F305.258
END DO GRB4F305.259
GRB4F305.260
CL 1.1 Set number of steps after which each ancillary field is updated INANCO1A.146
C Zero is used for fields not to be updated INANCO1A.147
INANCO1A.148
O_SECS_PER_STEP=O_SECS_P_P/O_STEPS_P_P INANCO1A.149
DO 110 I=1,NANCIL_FIELDS INANCO1A.150
STEPS(I)=0 INANCO1A.151
IF (FIELDCODE(1,I).EQ.4) THEN INANCO1A.152
IF (MOD(3600*FIELDCODE(2,I),O_SECS_PER_STEP).EQ.0) THEN INANCO1A.153
STEPS(I)=FIELDCODE(2,I)*O_STEPS_P_P*3600/O_SECS_P_P INANCO1A.154
ELSE INANCO1A.155
WRITE(6,*)'Updating interval of ',FIELDCODE(2,I),' hours GIE0F403.292
& not compatible with length of ocean timestep' INANCO1A.157
ICODE=1 INANCO1A.158
CMESSAGE='INANCLO=updating interval incompatible with tstep' INANCO1A.159
RETURN INANCO1A.160
ENDIF INANCO1A.161
END IF INANCO1A.162
IF (FIELDCODE(1,I).EQ.3) THEN INANCO1A.163
IF (MOD(86400*FIELDCODE(2,I),O_SECS_PER_STEP).EQ.0) THEN INANCO1A.164
STEPS(I)=FIELDCODE(2,I)*O_STEPS_P_P*86400/O_SECS_P_P INANCO1A.165
ELSE INANCO1A.166
WRITE(6,*)'Updating interval of ',FIELDCODE(2,I),' days not GIE0F403.293
& compatible with length of ocean timestep' INANCO1A.168
ICODE=1 INANCO1A.169
CMESSAGE='INANCLO=updating interval incompatible with tstep' INANCO1A.170
RETURN INANCO1A.171
ENDIF INANCO1A.172
END IF INANCO1A.173
INANCO1A.174
C If update interval in months or years test each day or each timestep INANCO1A.175
C as appropriate INANCO1A.176
INANCO1A.177
IF (FIELDCODE(1,I).EQ.2.OR.FIELDCODE(1,I).EQ.1) THEN INANCO1A.178
IF (MOD(86400,O_SECS_PER_STEP).EQ.0) THEN INANCO1A.179
STEPS(I)=O_STEPS_P_P*86400/O_SECS_P_P INANCO1A.180
ELSE INANCO1A.181
STEPS(I)=1 INANCO1A.182
ENDIF INANCO1A.183
END IF INANCO1A.184
110 CONTINUE INANCO1A.185
INANCO1A.186
CL 1.2 Set master number of steps ANCILLARY_STEPS at which INANCO1A.187
CL individual switches are tested. INANCO1A.188
INANCO1A.189
C Find first active field INANCO1A.190
INANCO1A.191
DO 120 I=1,NANCIL_FIELDS INANCO1A.192
IF (STEPS(I).GT.0) THEN INANCO1A.193
ANCILLARY_STEPS=STEPS(I) INANCO1A.194
GOTO 121 INANCO1A.195
END IF INANCO1A.196
120 CONTINUE INANCO1A.197
INANCO1A.198
C No above fields found INANCO1A.199
INANCO1A.200
ANCILLARY_STEPS=0 INANCO1A.201
INANCO1A.202
GOTO 900 INANCO1A.203
121 CONTINUE INANCO1A.204
ITEM=I INANCO1A.205
INANCO1A.206
CL Set ANCILLARY_STEPS to lowest common denominater of INANCO1A.207
CL frequencies for active fields INANCO1A.208
INANCO1A.209
DO 122 I=ITEM+1,NANCIL_FIELDS INANCO1A.210
IF (STEPS(I).LT.ANCILLARY_STEPS.AND.STEPS(I).GT.0) THEN INANCO1A.211
IF (MOD(ANCILLARY_STEPS,STEPS(I)).EQ.0) THEN INANCO1A.212
ANCILLARY_STEPS=STEPS(I) INANCO1A.213
ELSE INANCO1A.214
J1=STEPS(I)-1 INANCO1A.215
DO 123 J=J1,1,-1 INANCO1A.216
IF ((MOD(ANCILLARY_STEPS,J).EQ.0).AND. INANCO1A.217
& (MOD(STEPS(I),J).EQ.0))THEN INANCO1A.218
GOTO 124 INANCO1A.219
ENDIF INANCO1A.220
123 CONTINUE INANCO1A.221
124 CONTINUE INANCO1A.222
ANCILLARY_STEPS=J INANCO1A.223
END IF INANCO1A.224
END IF INANCO1A.225
122 CONTINUE INANCO1A.226
INANCO1A.227
CL 1.3 Set number of levels for each ancillary field GMB1F304.27
C default number of levels is 1 GMB1F304.28
DO I=1,NANCIL_FIELDS GMB1F304.29
LEVELS(I)=1 GMB1F304.30
END DO GMB1F304.31
INANCO1A.229
CL 1.4 Read headers INANCO1A.230
INANCO1A.231
LOOKUPS=0 INANCO1A.232
INANCO1A.233
DO 140 J=1,NDATASETS INANCO1A.234
INANCO1A.235
CL Check whether each physical file is needed INANCO1A.236
INANCO1A.237
LFILE=.FALSE. INANCO1A.238
DO 141 I=1,NANCIL_FIELDS INANCO1A.239
IF (FILEANCIL(I).EQ.J.AND.STEPS(I).GT.0) THEN INANCO1A.240
LFILE=.TRUE. INANCO1A.241
END IF INANCO1A.242
141 CONTINUE INANCO1A.243
INANCO1A.244
IF(LFILE) THEN INANCO1A.245
INANCO1A.246
CL Read headers for physical files required INANCO1A.247
INANCO1A.248
NFTIN=FTNANCIL(J) INANCO1A.249
INANCO1A.250
C Open required ancillary file INANCO1A.251
CALL FILE_OPEN(NFTIN,FT_ENVIRON(NFTIN), GPB1F305.46
& LEN_FT_ENVIR(NFTIN),0,0,ICODE) GPB1F305.47
IF(ICODE.NE.0)THEN INANCO1A.254
CMESSAGE='INANCLO: Error opening file' INANCO1A.255
write(6,*) 'INANCILO: Error opening file on unit ',NFTIN, GRR1F405.28
& ' accessed from env.var.: ',FT_ENVIRON(NFTIN) GRR1F405.29
RETURN INANCO1A.256
ENDIF INANCO1A.257
INANCO1A.258
CALL SETPOS(NFTIN,0,ICODE) ODR1F404.12
ODR1F404.13
! Read in fixed header to get array dimensions ODR1F404.14
CALL READ_FLH(NFTIN,FIXHD(1,J),LEN_FIXHD,ICODE,CMESSAGE) ODR1F404.15
IF (ICODE.GT.0) THEN ODR1F404.16
WRITE (6,*) ' Error in reading fixed header for file ',J ODR1F404.17
GO TO 9999 ! Return ODR1F404.18
ENDIF ODR1F404.19
ODR1F404.20
! Check for negative dimensions ODR1F404.21
IF (FIXHD(101,J).LE.0) FIXHD(101,J)=1 ODR1F404.22
IF (FIXHD(106,J).LE.0) FIXHD(106,J)=1 ODR1F404.23
IF (FIXHD(111,J).LE.0) FIXHD(111,J)=1 ODR1F404.24
IF (FIXHD(112,J).LE.0) FIXHD(112,J)=1 ODR1F404.25
IF (FIXHD(151,J).LE.0) FIXHD(151,J)=1 ODR1F404.26
IF (FIXHD(152,J).LE.0) FIXHD(152,J)=1 ODR1F404.27
IF (FIXHD(161,J).LE.0) FIXHD(161,J)=1 ODR1F404.28
ODR1F404.29
! Set start position in lookup table ODR1F404.30
LOOKUP_START(J) = LOOKUPS+1 ODR1F404.31
ODR1F404.32
! Check sufficient space for lookup headers ODR1F404.33
IF (LOOKUPS+FIXHD(152,J).GT.NLOOKUPS) THEN ODR1F404.34
WRITE (6,*) 'No room in LOOKUP table for Ancillary File ',J ODR1F404.35
CMESSAGE='INANCILO: Insufficient space for LOOKUP headers' ODR1F404.36
ICODE=14 ODR1F404.37
GO TO 9999 ! Return ODR1F404.38
END IF ODR1F404.39
ODR1F404.40
CALL SETPOS (NFTIN,0,ICODE) ODR1F404.41
IF (ICODE.GT.0) THEN ODR1F404.42
WRITE (6,*) ' ERROR in SETPOS called from INANCO1A' ODR1F404.43
WRITE (6,*) ' SETPOS attempted with Unit No ',NFTIN ODR1F404.44
CMESSAGE = 'INANCO1A : ERROR in SETPOS' ODR1F404.45
GO TO 9999 ! Return ODR1F404.46
ENDIF ODR1F404.47
ODR1F404.48
! Read in all Header records ODR1F404.49
ODR1F404.50
CALL READHEAD(NFTIN, ODR1F404.51
& FIXHD(1,J),LEN_FIXHD, ODR1F404.52
& INTHD(1,J),FIXHD(101,J), ODR1F404.53
& REALHD(1,J),FIXHD(106,J), ODR1F404.54
& LEVDEPC,FIXHD(111,J),FIXHD(112,J), ODR1F404.55
& DUMMY,DUMMY,DUMMY, ODR1F404.56
& DUMMY,DUMMY,DUMMY, ODR1F404.57
& DUMMY,DUMMY,DUMMY, ODR1F404.58
& DUMMY,DUMMY, ODR1F404.59
& DUMMY,DUMMY, ODR1F404.60
& DUMMY,DUMMY, ODR1F404.61
& DUMMY,DUMMY, ODR1F404.62
& DUMMY,DUMMY, ODR1F404.63
& LOOKUP(1,LOOKUPS+1),FIXHD(151,J),FIXHD(152,J), ODR1F404.64
& FIXHD(161,J), ODR1F404.65
*CALL ARGPPX ODR1F404.66
& START_BLOCK,ICODE,CMESSAGE) ODR1F404.67
ODR1F404.68
IF (ICODE.GT.0) THEN ODR1F404.69
WRITE(6,*) 'ERROR in READHEAD for Ancillary File ',J ODR1F404.70
WRITE(6,*) 'Unit Number ',NFTIN ODR1F404.71
GO TO 9999 ! Return ODR1F404.72
ENDIF ODR1F404.73
ODR1F404.74
! Check calendar indicator ODR1F404.75
IF (( LCAL360 .and. FIXHD(8,J).NE.2) .or. ODR1F404.76
& (.not.LCAL360 .and. FIXHD(8,J).NE.1) ) THEN ODR1F404.77
ICODE=100+J ODR1F404.78
CMESSAGE='INANCILO : Wrong calendar set in Ancillary File' ODR1F404.79
WRITE (6,*) ' ******** Error in INANCILO ********' ODR1F404.80
WRITE (6,*) ' Wrong calendar setting in Ancillary File ',J ODR1F404.81
IF (LCAL360) THEN ODR1F404.82
WRITE (6,*) ' Model run is set up for 360 day calendar.' ODR1F404.83
WRITE (6,*) ' Ancillary File is for 365 day calendar.' ODR1F404.84
ELSE ODR1F404.85
WRITE (6,*) ' Model run is set up for 365 day calendar.' ODR1F404.86
WRITE (6,*) ' Ancillary File is for 360 day calendar.' ODR1F404.87
ENDIF ODR1F404.88
WRITE (6,*) ' Rerun with correct ancillary file.' ODR1F404.89
GO TO 9999 ! Return ODR1F404.90
ENDIF ODR1F404.91
INANCO1A.286
IF(FIXHD(100,J).GT.0) THEN INANCO1A.289
INANCO1A.290
C Check validity of integer data and print out information INANCO1A.315
IF (INTHD(6,J).NE.IMT) THEN INANCO1A.316
WRITE(6,*)'Mismatch in row_length:data set has',INTHD GIE0F403.294
& (6,J),'required value is',IMT INANCO1A.318
ICODE=19 INANCO1A.319
CMESSAGE='INANCILO:integer header error' INANCO1A.320
RETURN INANCO1A.321
END IF INANCO1A.322
INANCO1A.323
IF(INTHD(7,J).NE.JMT_GLOBAL) THEN ORH3F402.375
WRITE(6,*)'Mismatch in numbers of rows:data set',J,'data set GIE0F403.295
& has',INTHD(7,J),'required value is ',JMT_GLOBAL ORH3F402.376
ICODE=20 INANCO1A.327
CMESSAGE='INANCILO:integer header error' INANCO1A.328
RETURN INANCO1A.329
END IF INANCO1A.330
INANCO1A.331
END IF INANCO1A.332
INANCO1A.333
IF(FIXHD(105,J).GT.0) THEN INANCO1A.336
INANCO1A.337
C Check validity of real data and print out information INANCO1A.362
INANCO1A.363
DO 143 K=1,6 INANCO1A.364
IF(REALHD(K,J).GT.(O_REALHD(K)+0.1).OR. INANCO1A.365
& REALHD(K,J).LT.(O_REALHD(K)-0.1))THEN INANCO1A.366
WRITE(6,*)'Mismatch in real header position',K,'data set GIE0F403.296
& has',REALHD(K,J),' required value is = ', O_REALHD(K) INANCO1A.368
ICODE=23 INANCO1A.369
CMESSAGE='INANCILO=real header error' INANCO1A.370
RETURN INANCO1A.371
END IF INANCO1A.372
143 CONTINUE INANCO1A.373
INANCO1A.374
END IF INANCO1A.375
INANCO1A.376
IF(FIXHD(110,J).GT.0) THEN GMB1F304.45
GMB1F304.46
C Check that level dependent constants match model depths. GMB1F304.73
C This step uses the logical function lner defined in the GMB1F304.74
C declaration statements at the top of the code. GMB1F304.75
GMB1F304.76
DO I = 1, LEN1_LEVDEPC GMB1F304.77
IF ( LNER ( LEVDEPC(I) , O_LEVDEPC(I) ) ) THEN GMB1F304.78
WRITE(6,*)'Error in level dependent constants:Level=',I GIE0F403.297
WRITE(6,*)'Dataset=',J GIE0F403.298
WRITE(6,*)'Value in model =',O_LEVDEPC(I) GIE0F403.299
WRITE(6,*)'Value in ancillary data =',LEVDEPC(I) GIE0F403.300
ICODE=26 GMB1F304.83
CMESSAGE='INANCILO: error in LEVDEPC.' GMB1F304.84
RETURN GMB1F304.85
END IF GMB1F304.86
END DO GMB1F304.87
GMB1F304.88
END IF ! FIXHD(110,I).GT.0 GMB1F304.89
GMB1F304.90
IF(FIXHD(150,J).GT.0) THEN INANCO1A.379
INANCO1A.380
NREC_O = 0 GDR7F400.57
DO I = 1,FIXHD(152,J) GDR7F400.58
IF (LOOKUP(MODEL_CODE,LOOKUPS+I) .eq. 0 .or. GDR7F400.59
& LOOKUP(MODEL_CODE,LOOKUPS+I) .eq. imdi) THEN GDR7F400.60
LOOKUP(MODEL_CODE,LOOKUPS+I) = ocean_im GDR7F400.64
NREC_O = NREC_O+1 GDR7F400.65
END IF GDR7F400.67
END DO GDR7F400.68
IF (NREC_O.GT.0) THEN GDR7F400.69
WRITE (6,*) ' ' GDR7F400.70
WRITE (6,*) ' INANCO1A : submodel_id in ',NREC_O, GDR7F400.71
& ' records set to ocean_im in ancillary file ',J GDR7F400.72
ENDIF GDR7F400.73
GDR7F400.74
INANCO1A.418
END IF INANCO1A.419
INANCO1A.420
LOOKUPS=LOOKUPS+FIXHD(152,J) INANCO1A.421
INANCO1A.422
ELSE INANCO1A.423
INANCO1A.424
CL If file not required, zero fixed length header INANCO1A.425
DO I=1,LEN_FIXHD INANCO1A.426
FIXHD(I,J)=0 GMB1F304.110
END DO INANCO1A.428
INANCO1A.429
END IF INANCO1A.430
INANCO1A.431
140 CONTINUE INANCO1A.432
INANCO1A.433
CL 1.5 Set positions in main data blocks INANCO1A.434
INANCO1A.435
C Items 1 and 2 not available for updating during run. INANCO1A.436
D1_ANCILADD(1)=1 INANCO1A.437
D1_ANCILADD(2)=1 INANCO1A.438
GMB1F304.111
DO I = 3, NANCIL_FIELDS GMB1F304.112
D1_ANCILADD(I)= SI(STASHANCIL(I)) GMB1F304.113
END DO GMB1F304.114
GMB1F304.115
INANCO1A.458
CL 1.6 Set positions of data INANCO1A.459
INANCO1A.460
DO 160 I=1,NANCIL_FIELDS INANCO1A.461
DO 162 J=1,LOOKUPS INANCO1A.462
INANCO1A.463
IF (LOOKUP(ITEM_CODE,J).EQ.STASHANCIL(I)) THEN INANCO1A.464
NLOOKUP(I)=J-LOOKUP_START(FILEANCIL(I))+1 INANCO1A.465
GOTO 161 INANCO1A.466
END IF INANCO1A.467
INANCO1A.468
162 CONTINUE INANCO1A.469
INANCO1A.470
C Find second occurence of data to set LOOKUP_STEP INANCO1A.471
INANCO1A.472
161 CONTINUE INANCO1A.473
LOOKUP_STEP(I)=0 INANCO1A.474
INANCO1A.475
DO 163 J1=J+LEVELS(I),LOOKUPS GMB1F304.116
IF (LOOKUP(ITEM_CODE,J1).EQ.STASHANCIL(I)) THEN INANCO1A.477
LOOKUP_STEP(I)=J1-NLOOKUP(I)-LOOKUP_START(FILEANCIL(I))+1 INANCO1A.478
GOTO 160 INANCO1A.479
END IF INANCO1A.480
163 CONTINUE INANCO1A.481
INANCO1A.482
160 CONTINUE INANCO1A.483
INANCO1A.484
CL 1.7 If a request is made to update a field, ensure that space for INANCO1A.485
CL that field has been allocted in D1. INANCO1A.486
INANCO1A.487
DO I=1,NANCIL_FIELDS INANCO1A.488
IF((FIELDCODE(1,I).GT.0).AND.(D1_ANCILADD(I).LE.1)) THEN INANCO1A.489
WRITE(6,*)' An address in D1 has not been set for ancillary INANCO1A.490
& field number ',I INANCO1A.491
ICODE=30 INANCO1A.492
CMESSAGE='INANCILO: updating for ancillary field is requested INANCO1A.493
& but no space has been allocated in D1' INANCO1A.494
RETURN INANCO1A.495
ENDIF INANCO1A.496
END DO INANCO1A.497
INANCO1A.498
C *ENDIF INANCO1A.499
INANCO1A.500
900 CONTINUE INANCO1A.501
9999 CONTINUE ODR1F404.92
RETURN INANCO1A.502
END INANCO1A.503
INANCO1A.504
INANCO1A.505
*ENDIF INANCO1A.506