SUBROUTINE INANCILA(LEN_FIXHD,LEN_INTHD,LEN_REALHD, !Intent (In) 2,5UJS1F401.278
& LEN1_LEVDEPC,LEN2_LEVDEPC, UJS1F401.279
& FIXHD,INTHD,REALHD,LOOKUP, UJS1F401.280
& A_FIXHD,A_REALHD,A_LEVDEPC, UJS1F401.281
& NDATASETS,NLOOKUPS,FTNANCIL, UJS1F401.282
& LOOKUP_START,LEN1_LOOKUP,ROW_LENGTH, UJS1F401.283
& P_ROWS,U_ROWS,P_LEVELS, UJS1F401.284
& TR_LEVELS,ST_LEVELS,SM_LEVELS, UJS1F401.285
& OZONE_LEVELS,TITLE, UJS1F401.286
*IF -DEF,RECON GDG0F401.757
& SI_ATMOS,SI_SLAB,SILEN, GDG0F401.758
& ANCILLARY_STEPS,STEPS_PER_HR, GDG0F401.760
*CALL ARGPPX 
GDG0F401.761
& ICODE,CMESSAGE,LCAL360) ! Intent (Out) GDG0F401.762
*ELSE GDG0F401.763
& SWITCH,NSWITCH, GDG0F401.764
& L_SSTANOM_SWITCH,D1_ANCILADD_PARM, GDG0F401.765
*CALL ARGPPX GDG0F401.766
& IOUNIT,ICODE,CMESSAGE,LCAL360) ! Intent (Out) GDG0F401.767
*ENDIF GDG0F401.768
GDG0F401.769
INANCA1A.58
IMPLICIT NONE INANCA1A.59
INANCA1A.60
LOGICAL LCAL360 ! Logical switch for 360-day calendar GSS1F304.344
GSS1F304.345
INTEGER INANCA1A.61
& LEN_FIXHD, ! Length of header blocks in ancillary INANCA1A.62
C ! data sets INANCA1A.63
& LEN_INTHD, ! INANCA1A.64
& LEN_REALHD, ! INANCA1A.65
& LEN1_LEVDEPC, ! Dimension of LEVDEPC in model INANCA1A.66
& LEN2_LEVDEPC INANCA1A.67
*IF -DEF,RECON INANCA1A.68
& ,ANCILLARY_STEPS, INANCA1A.69
& STEPS_PER_HR INANCA1A.70
*ENDIF INANCA1A.71
INANCA1A.72
*IF DEF,RECON INANCA1A.73
INANCA1A.74
& ,NSWITCH, ! No of ancillary fields being updated INANCA1A.75
C ! at reconfigeration INANCA1A.76
& SWITCH(NSWITCH),! Control switches at reconfigeration INANCA1A.77
& D1_ANCILADD_PARM !Address of ancillary field in main data block INANCA1A.78
& (NSWITCH) !passed back thro arg list. Same as D1_ANCILADD INANCA1A.79
INANCA1A.80
LOGICAL INANCA1A.81
& L_SSTANOM_SWITCH ! switch for sst anomaly creation INANCA1A.82
INANCA1A.83
*ENDIF INANCA1A.84
INANCA1A.85
INTEGER INANCA1A.86
& NDATASETS, ! No of physical files INANCA1A.87
& NLOOKUPS, ! No of lookups required(set by User I.) INANCA1A.88
& IOUNIT, INANCA1A.89
& FTNANCIL(NDATASETS), ! Fortran nos of physical files INANCA1A.90
& LOOKUP_START(NDATASETS),!start of each individual lookup INANCA1A.91
C !in overall LOOKUP array INANCA1A.92
& LEN1_LOOKUP, ! Length of PP header INANCA1A.93
& ROW_LENGTH, ! Atmosphere model dimensions INANCA1A.94
& P_ROWS, ! No. of rows for pressure-type variables RB221193.22
& U_ROWS, ! No. of rows for wind-type variables RB221193.23
& P_LEVELS, ! No. of pressure levels RB221193.24
& TR_LEVELS, ! No. of tracer levels RB221193.25
& FILE_LEVELS, ! Number of levels of data in files INANCA1A.102
C ! contining multi-level data. INANCA1A.103
& ST_LEVELS, ! No. of soil temperature levels UJS1F401.287
& SM_LEVELS, ! No. of soil moisture levels UJS1F401.288
& OZONE_LEVELS INANCA1A.105
*IF -DEF,RECON INANCA1A.106
GDR8F400.77
! For atmos only runs SI_SLAB is a copy of SI_ATMOS GDR8F400.78
! SI_SLAB is only used in SLAB runs. GDR8F400.79
GDR8F400.80
& ,SILEN ! Length for SI_ATMOS/SLAB arrays GDR8F400.81
& ,SI_ATMOS(SILEN) ! ) STASHin addresses of atmos and GDR8F400.82
& ,SI_SLAB(SILEN) ! ) slab ancillary fields. GDR8F400.83
*ENDIF INANCA1A.109
CHARACTER*80 TITLE(NDATASETS) ! Titles of each dataset INANCA1A.110
INANCA1A.111
INTEGER INANCA1A.112
& FIXHD(LEN_FIXHD,NDATASETS),! Overall Fixed header array INANCA1A.113
& A_FIXHD(LEN_FIXHD), ! Fixed header for Dump AJS1F400.13
& INTHD(LEN_INTHD,NDATASETS),! Overall Integer header array INANCA1A.114
& LOOKUP(LEN1_LOOKUP,NLOOKUPS),!Overall Lookup array INANCA1A.115
& ICODE ! Return code =0 Normal Exit INANCA1A.116
C ! >0 Error INANCA1A.117
INANCA1A.118
REAL INANCA1A.119
& REALHD(LEN_REALHD,NDATASETS),! INANCA1A.120
& A_REALHD(LEN_REALHD),! INANCA1A.121
& A_LEVDEPC(LEN1_LEVDEPC,LEN2_LEVDEPC), INANCA1A.122
& LEVDEPC(P_LEVELS*4)! Space to hold level dependent constants INANCA1A.123
C ! from data set INANCA1A.124
INANCA1A.125
CHARACTER*100 INANCA1A.126
& CMESSAGE ! Out error message if I>0 INANCA1A.127
INANCA1A.128
! Comdecks:---------------------------------------------------------- GDG0F401.770
*CALL CSUBMODL GDG0F401.771
*CALL CPPXREF GDG0F401.772
*CALL PPXLOOK GDG0F401.773
*CALL MODEL GDG0F401.774
*CALL CLOOKADD GDG0F401.775
*CALL CANCILA GDG0F401.776
*CALL CSENARIO AWI1F403.95
*CALL NSTYPES ABX2F404.66
*CALL C_MDI GDG0F401.777
*IF -DEF,RECON GDG0F401.778
*CALL CENVIR GDG0F401.779
*ENDIF GDG0F401.780
GDG0F401.781
GDR1F401.75
! Comdecks for ancillary files/fields. GDR1F401.76
*CALL CANCFLDA GDR1F401.77
GDR1F401.78
CL External subroutines called: INANCA1A.135
INANCA1A.136
EXTERNAL INANCA1A.137
*IF -DEF,RECON GDR6F404.3
& FILE_OPEN, GDR6F404.4
*ENDIF GDR6F404.5
& READ_FLH, READHEAD, SETPOS GDR6F404.6
INANCA1A.143
CL Namelist input INANCA1A.144
INANCA1A.145
NAMELIST/ANCILCTA/L_SSTANOM,LAMIPII GRS2F404.216
GDR6F404.7
! UPANCA Namelist GDR6F404.8
INTEGER GDR6F404.9
& ANC_REF_NO ! Ancil Ref. No : See comdeck CANCFLDA GDR6F404.10
& ,PERIOD ! Period of Updating Interval (Y/M/D/H) GDR6F404.11
& ,INTERVAL ! Updating Interval GDR6F404.12
GDR6F404.13
NAMELIST /UPANCA/ ANC_REF_NO,PERIOD,INTERVAL GDR6F404.14
INANCA1A.147
C Local Variables INANCA1A.148
INANCA1A.149
INTEGER INANCA1A.150
& I, ! INANCA1A.151
& ITEM, ! INANCA1A.152
& J, ! INANCA1A.153
& J1, ! INANCA1A.154
& K, ! INANCA1A.155
& LEN_IO, ! INANCA1A.156
& LOOKUPS, ! INANCA1A.157
& NFTIN, ! Current FTN number for ancillary data INANCA1A.158
& START_BLOCK, ! AJS1F400.14
& JSOIL_DEPTHS ! Pointer for soil thicknesses in level AJS1F400.15
C ! dep.consts. AJS1F400.16
& ,STASH_CODE ! Stash item code GDR7F400.22
& ,NREC_A,NREC_S ! No of atmos & slab records GDR7F400.23
& ,STASH_ADDR ! Stash address GDR8F400.84
& ,DUMMY ! APB4F401.591
& ,N_ANC_UPD ! No of ancillaries to be updated GDR6F404.15
DATA DUMMY /1/ APB4F401.592
INANCA1A.171
CHARACTER*8 CPERIOD ! PERIOD in characters. GDR6F404.16
LOGICAL INANCA1A.176
& LFILE ! INANCA1A.177
INANCA1A.178
REAL P1,P2 INANCA1A.179
LOGICAL LNER INANCA1A.180
LNER(P1,P2) = ((ABS(P1-P2)) .GT. (1.E-6*ABS(P1+P2))) INANCA1A.181
INANCA1A.182
CL Internal Structure INANCA1A.183
INANCA1A.184
ICODE=0 INANCA1A.185
CMESSAGE=' ' INANCA1A.186
IOUNIT=0 INANCA1A.187
INANCA1A.188
C INANCA1A.189
CL 1. Initialisation for atmosphere model INANCA1A.190
INANCA1A.191
DO I=1,NANCIL_FIELDS INANCA1A.192
FILEANCIL(I) =ANCIL_FILE_NO(I) GDR1F401.79
STASHANCIL(I)=ITEM_CODES_ANCIL(I) GDR1F401.80
ENDDO INANCA1A.195
INANCA1A.196
*IF -DEF,RECON INANCA1A.197
INANCA1A.198
! Set default values GRS2F404.217
GRS2F404.218
L_SSTANOM=.FALSE. INANCA1A.199
LAMIPII=.FALSE. GRS2F404.219
GRS2F404.220
CL Read in control information from namelist RB221193.29
INANCA1A.201
REWIND 5 GRB1F400.85
READ(5,ANCILCTA) INANCA1A.202
GDR6F404.17
! Initialise FIELDCODE from Namelist UPANCA GDR6F404.18
N_ANC_UPD = 0 GDR6F404.19
DO I=1,NANCIL_FIELDS GDR6F404.20
READ (5,UPANCA,ERR=101,END=101) GDR6F404.21
FIELDCODE(1,ANC_REF_NO) = PERIOD GDR6F404.22
FIELDCODE(2,ANC_REF_NO) = INTERVAL GDR6F404.23
N_ANC_UPD = N_ANC_UPD+1 GDR6F404.24
ENDDO GDR6F404.25
GDR6F404.26
101 CONTINUE GDR6F404.27
WRITE (6,*) ' ' GDR6F404.28
WRITE (6,*) N_ANC_UPD,' Atmos & Slab Ancillaries to be updated.' GDR6F404.29
DO I=1,NANCIL_FIELDS GDR6F404.30
IF (FIELDCODE(1,I).GT.0) THEN GDR6F404.31
IF (FIELDCODE(1,I).EQ.1) CPERIOD=' Years' GDR6F404.32
IF (FIELDCODE(1,I).EQ.2) CPERIOD=' Months' GDR6F404.33
IF (FIELDCODE(1,I).EQ.3) CPERIOD=' Days' GDR6F404.34
IF (FIELDCODE(1,I).EQ.4) CPERIOD=' Hours' GDR6F404.35
WRITE (6,*) 'Anc Ref No ',I,' Stash code ',ITEM_CODES_ANCIL(I), GDR6F404.36
& ' Interval ',FIELDCODE(2,I),CPERIOD GDR6F404.37
ENDIF GDR6F404.38
ENDDO GDR6F404.39
WRITE (6,*) ' ' GDR6F404.40
INANCA1A.203
! Check that ancillary field has valid address (>1) before proceding GRB4F305.221
! to try and update it. If not, switch off updating via FIELDCODE. GRB4F305.222
DO I=1,NANCIL_FIELDS GRB4F305.223
if (model_codes_ancil(i).eq.slab_im) then GDR1F401.81
stash_addr = si_slab(stashancil(i)) GDR8F400.86
else GDR8F400.87
stash_addr = si_atmos(stashancil(i)) GDR8F400.88
endif GDR8F400.89
IF (stash_addr .le. 1) THEN GDR8F400.90
IF (FIELDCODE(1,I).gt.0) THEN GRB4F305.225
WRITE(6,*)' INANCILA: update requested for item ',i, GRR1F405.21
& ' STASHcode ',stashancil(i),' but prognostic address not set' GRR1F405.22
WRITE(6,*)' FIELDCODE values reset to zeroes' GIE0F403.273
FIELDCODE(1,I) = 0 GRB4F305.229
FIELDCODE(2,I) = 0 GRB4F305.230
END IF GRB4F305.231
END IF GRB4F305.232
END DO GRB4F305.233
GRB4F305.234
CL 1.1 Set number of steps after which each ancillary field is updated INANCA1A.204
C Zero is used for fields not to be updated INANCA1A.205
INANCA1A.206
DO I=1,NANCIL_FIELDS INANCA1A.207
STEPS(I)=0 INANCA1A.208
IF (FIELDCODE(1,I).EQ.4)THEN INANCA1A.209
STEPS(I)=FIELDCODE(2,I)*STEPS_PER_HR INANCA1A.210
END IF INANCA1A.211
IF (FIELDCODE(1,I).EQ.3) THEN INANCA1A.212
STEPS(I)=FIELDCODE(2,I)*24*STEPS_PER_HR INANCA1A.213
END IF INANCA1A.214
INANCA1A.215
IF (LCAL360) THEN GSS1F304.346
IF (FIELDCODE(1,I).EQ.2) THEN INANCA1A.217
STEPS(I)=FIELDCODE(2,I)*30*24*STEPS_PER_HR INANCA1A.218
END IF INANCA1A.219
IF (FIELDCODE(1,I).EQ.1) THEN INANCA1A.220
STEPS(I)=FIELDCODE(2,I)*360*24*STEPS_PER_HR INANCA1A.221
END IF INANCA1A.222
ELSE GSS1F304.347
C Gregorian calender: INANCA1A.224
C If update interval is months or years, test each day. Further testing INANCA1A.225
C done in REPLANCA. INANCA1A.226
INANCA1A.227
IF (FIELDCODE(1,I).EQ.1.OR.FIELDCODE(1,I).EQ.2)THEN INANCA1A.228
STEPS(I)=24*STEPS_PER_HR INANCA1A.229
END IF INANCA1A.230
END IF GSS1F304.348
INANCA1A.232
END DO INANCA1A.233
INANCA1A.234
CL 1.2 Set master number of steps ANCILLARY_STEPS at which INANCA1A.235
CL individual switches are tested. INANCA1A.236
INANCA1A.237
C Find first active field INANCA1A.238
INANCA1A.239
DO I=1,NANCIL_FIELDS INANCA1A.240
IF (STEPS(I).GT.0) THEN INANCA1A.241
ANCILLARY_STEPS=STEPS(I) INANCA1A.242
GOTO 121 INANCA1A.243
END IF INANCA1A.244
END DO INANCA1A.245
INANCA1A.246
C No above fields found INANCA1A.247
INANCA1A.248
ANCILLARY_STEPS=0 INANCA1A.249
INANCA1A.250
GOTO 900 INANCA1A.251
121 ITEM=I INANCA1A.252
INANCA1A.253
CL Set ANCILLARY_STEPS to lowest common denominater of INANCA1A.254
CL frequencies for active fields INANCA1A.255
INANCA1A.256
DO I=ITEM+1,NANCIL_FIELDS INANCA1A.257
IF (STEPS(I).LT.ANCILLARY_STEPS INANCA1A.258
* .AND. STEPS(I).GT.0) THEN INANCA1A.259
IF (MOD(ANCILLARY_STEPS,STEPS(I)).EQ.0) THEN INANCA1A.260
ANCILLARY_STEPS=STEPS(I) INANCA1A.261
ELSE INANCA1A.262
J1=STEPS(I)-1 INANCA1A.263
DO J=J1,1,-1 INANCA1A.264
IF ((MOD(ANCILLARY_STEPS,J).EQ.0).AND. INANCA1A.265
& (MOD(STEPS(I),J).EQ.0)) THEN INANCA1A.266
GOTO 124 INANCA1A.267
ENDIF INANCA1A.268
END DO INANCA1A.269
124 ANCILLARY_STEPS = J INANCA1A.270
END IF INANCA1A.271
END IF INANCA1A.272
END DO INANCA1A.273
INANCA1A.274
CL 1.2.4 Sea surface temperature must be updated when sea ice is update INANCA1A.275
INANCA1A.276
IF (STEPS(27).GT.0.AND.STEPS(28).LE.0) THEN INANCA1A.277
STEPS(28)=1 INANCA1A.278
END IF INANCA1A.279
INANCA1A.280
*ELSE INANCA1A.281
INANCA1A.282
CL 1.1 Set control switches for reconfigeration INANCA1A.283
INANCA1A.284
ITEM=MAX(NANCIL_FIELDS,NSWITCH) INANCA1A.285
DO I=1,ITEM INANCA1A.286
FIELDCODE(I)=SWITCH(I) INANCA1A.287
END DO INANCA1A.288
INANCA1A.289
CL 1.1.5 Sea surface temperature anomaly switches on climatological sst INANCA1A.290
INANCA1A.291
L_SSTANOM= L_SSTANOM_SWITCH INANCA1A.292
IF (L_SSTANOM) THEN INANCA1A.293
FIELDCODE(28)=1 INANCA1A.294
END IF INANCA1A.295
INANCA1A.296
INANCA1A.297
CL 1.2.5 Sea surface temperature must be updated when sea ice is update INANCA1A.298
INANCA1A.299
IF (FIELDCODE(27).GT.0.AND.FIELDCODE(28).LE.0) THEN INANCA1A.300
FIELDCODE(28)=1 INANCA1A.301
END IF INANCA1A.302
INANCA1A.303
*ENDIF INANCA1A.304
INANCA1A.305
CL 1.3 Set number of headers for each ancillary field INANCA1A.306
INANCA1A.307
DO I=1,NANCIL_FIELDS INANCA1A.308
LEVELS(I)=1 INANCA1A.309
C Multilayer hydrology INANCA1A.310
IF(I.EQ.36)LEVELS(I)=SM_LEVELS UJS1F401.289
C Multilayer aerosols RB221193.30
IF(I.GE.41.AND.I.LE.43) LEVELS(I)=TR_LEVELS RB221193.31
C Multilayer murk concentration and source GRB0F304.62
IF(I.GE.44.AND.I.LE.45) LEVELS(I)=P_LEVELS GRB0F304.63
C Multilayer user ancillaries GRB0F304.64
IF(I.GE.90.AND.I.LE.109) LEVELS(I)=P_LEVELS GDG2F405.110
! Multi-level ancillaries for sulphur cycle GDR1F401.84
IF (I.EQ.72) LEVELS(I) = P_LEVELS GDR1F401.85
IF (I.EQ.73) LEVELS(I) = P_LEVELS GDR1F401.86
IF (I.EQ.74) LEVELS(I) = P_LEVELS GDR1F401.87
IF (I.EQ.75) LEVELS(I) = P_LEVELS GDR1F401.88
IF (I.EQ.76) LEVELS(I) = P_LEVELS GDR1F401.89
IF (I.EQ.82) LEVELS(I) = NSULPAT AWI1F403.96
IF (I.EQ.83) LEVELS(I) = NTYPE ABX2F404.67
IF (I.EQ.84) LEVELS(I) = NPFT ABX2F404.68
IF (I.EQ.85) LEVELS(I) = NPFT ABX2F404.69
END DO INANCA1A.312
INANCA1A.313
LEVELS(7)=OZONE_LEVELS INANCA1A.314
LEVELS(10)=ST_LEVELS UJS1F401.290
INANCA1A.316
RB221193.32
CL 1.4 Read headers INANCA1A.317
INANCA1A.318
LOOKUPS=0 INANCA1A.319
INANCA1A.320
DO I=1,NDATASETS INANCA1A.321
INANCA1A.322
C Initialise LOOKUP_START (=0 implies file I not required) ADR1F304.109
LOOKUP_START(I)=0 ADR1F304.110
ADR1F304.111
CL Check whether each physical file is needed INANCA1A.323
INANCA1A.324
LFILE=.FALSE. INANCA1A.325
DO 141 J=1,NANCIL_FIELDS INANCA1A.326
INANCA1A.327
*IF DEF,RECON INANCA1A.328
INANCA1A.329
IF (FILEANCIL(J).EQ.I.AND.FIELDCODE(J).GT.0) THEN INANCA1A.330
INANCA1A.331
*ELSE INANCA1A.332
INANCA1A.333
IF (FILEANCIL(J).EQ.I.AND.STEPS(J).GT.0) THEN INANCA1A.334
INANCA1A.335
*ENDIF INANCA1A.336
INANCA1A.337
LFILE=.TRUE. INANCA1A.338
END IF INANCA1A.339
141 CONTINUE INANCA1A.340
INANCA1A.341
IF(LFILE) THEN INANCA1A.342
INANCA1A.343
WRITE(6,*) ' ' UDG6F400.62
WRITE(6,*) ' Ancillary data file ',I,', unit no ',FTNANCIL(I), GDR1F401.82
& ', ',TITLE(I) GDR1F401.83
INANCA1A.346
CL Read headers for physical files required INANCA1A.347
INANCA1A.348
NFTIN=FTNANCIL(I) INANCA1A.349
INANCA1A.350
CL 1.4.1 Buffer in fixed length header record INANCA1A.351
INANCA1A.352
*IF -DEF,RECON INANCA1A.353
INANCA1A.354
CALL FILE_OPEN(NFTIN,FT_ENVIRON(NFTIN), GPB1F305.43
& LEN_FT_ENVIR(NFTIN),0,0,ICODE) GPB1F305.44
IF(ICODE.NE.0)THEN INANCA1A.357
CMESSAGE='INANCLA: Error opening file' INANCA1A.358
write(6,*) 'INANCILA: Error opening file on unit ',NFTIN, GRR1F405.23
& ' accessed from env.var.: ',FT_ENVIRON(NFTIN) GRR1F405.24
RETURN INANCA1A.359
ENDIF INANCA1A.360
*ENDIF INANCA1A.361
CALL SETPOS(NFTIN,0,ICODE) GTD0F400.86
INANCA1A.363
C Read in fixed header to get array dimensions APB4F401.593
CALL READ_FLH(NFTIN,FIXHD(1,I),LEN_FIXHD,ICODE,CMESSAGE) APB4F401.594
IF (ICODE.GT.0) THEN APB4F401.595
WRITE (6,*) ' Error in reading fixed header for file ',I APB4F401.596
GO TO 9999 ! Return APB4F401.597
ENDIF APB4F401.598
APB4F401.599
C Check for negative dimensions APB4F401.600
IF (FIXHD(101,I).LE.0) FIXHD(101,I)=1 APB4F401.601
IF (FIXHD(106,I).LE.0) FIXHD(106,I)=1 APB4F401.602
IF (FIXHD(111,I).LE.0) FIXHD(111,I)=1 APB4F401.603
IF (FIXHD(112,I).LE.0) FIXHD(112,I)=1 APB4F401.604
IF (FIXHD(151,I).LE.0) FIXHD(151,I)=1 APB4F401.605
IF (FIXHD(152,I).LE.0) FIXHD(152,I)=1 APB4F401.606
IF (FIXHD(161,I).LE.0) FIXHD(161,I)=1 APB4F401.607
APB4F401.608
C Set start position of boundary fields for file APB4F401.609
LOOKUP_START(I)=LOOKUPS+1 APB4F401.610
APB4F401.611
IF (LOOKUPS+FIXHD(152,I).GT.NLOOKUPS) THEN APB4F401.612
WRITE (6,*) 'No room in LOOKUP table for Ancillary File ',I APB4F401.613
CMESSAGE='INANCILA: Insufficient space for LOOKUP headers' APB4F401.614
ICODE=14 APB4F401.615
GO TO 9999 ! Return APB4F401.616
END IF APB4F401.617
APB4F401.618
CALL SETPOS(NFTIN,0,ICODE) APB4F401.619
IF (ICODE.GT.0) THEN APB4F401.620
WRITE (6,*) ' ERROR in SETPOS called from INANCA1A' APB4F401.621
WRITE (6,*) ' SETPOS attempted with Unit No ',NFTIN APB4F401.622
CMESSAGE = 'INANCA1A : ERROR in SETPOS' APB4F401.623
GO TO 9999 ! Return APB4F401.624
ENDIF APB4F401.625
APB4F401.626
CALL READHEAD(NFTIN, APB4F401.627
& FIXHD(1,I),LEN_FIXHD, APB4F401.628
& INTHD(1,I),FIXHD(101,I), APB4F401.629
& REALHD(1,I),FIXHD(106,I), APB4F401.630
& LEVDEPC,FIXHD(111,I),FIXHD(112,I), APB4F401.631
& DUMMY,DUMMY,DUMMY, APB4F401.632
& DUMMY,DUMMY,DUMMY, APB4F401.633
& DUMMY,DUMMY,DUMMY, APB4F401.634
& DUMMY,DUMMY, APB4F401.635
& DUMMY,DUMMY, APB4F401.636
& DUMMY,DUMMY, APB4F401.637
& DUMMY,DUMMY, APB4F401.638
& DUMMY,DUMMY, APB4F401.639
& LOOKUP(1,LOOKUPS+1),FIXHD(151,I),FIXHD(152,I), APB4F401.640
& FIXHD(161,I), APB4F401.641
*CALL ARGPPX APB4F401.642
& START_BLOCK,ICODE,CMESSAGE) APB4F401.643
APB4F401.644
IF (ICODE.GT.0) THEN APB4F401.645
WRITE(6,*) 'ERROR in READHEAD for Ancillary File ',I APB4F401.646
WRITE(6,*) 'Unit Number ',NFTIN APB4F401.647
GO TO 9999 ! Return APB4F401.648
ENDIF APB4F401.649
INANCA1A.365
! Check calendar indicator GDR6F404.77
IF (( LCAL360 .and. FIXHD(8,I).NE.2) .or. GDR6F404.78
& (.not.LCAL360 .and. FIXHD(8,I).NE.1) ) THEN GDR6F404.79
ICODE=100+I GDR6F404.80
CMESSAGE='INANCILA : Wrong calendar set in Ancillary File' GDR6F404.81
WRITE (6,*) ' ******** Error in INANCILA ********' GDR6F404.82
WRITE (6,*) ' Wrong calendar setting in Ancillary File ',I GDR6F404.83
IF (LCAL360) THEN GDR6F404.84
WRITE (6,*) ' Model run is set up for 360 day calendar.' GDR6F404.85
WRITE (6,*) ' Ancillary File is for 365 day calendar.' GDR6F404.86
ELSE GDR6F404.87
WRITE (6,*) ' Model run is set up for 365 day calendar.' GDR6F404.88
WRITE (6,*) ' Ancillary File is for 360 day calendar.' GDR6F404.89
ENDIF GDR6F404.90
WRITE (6,*) ' Rerun with correct ancillary file.' GDR6F404.91
GO TO 9999 ! Return GDR6F404.92
ENDIF GDR6F404.93
INANCA1A.380
FILE_LEVELS=1 INANCA1A.381
INANCA1A.382
IF(I.EQ.1) THEN INANCA1A.383
FILE_LEVELS=OZONE_LEVELS INANCA1A.384
ELSE IF(I.EQ.2) THEN INANCA1A.385
FILE_LEVELS=SM_LEVELS UJS1F401.291
C This is the maximum value that might be present on the ancillary INANCA1A.387
C file if it includes soil moisture in layers; otherwise only single INANCA1A.388
C level data is present and PR_FIXHD will not check value since INANCA1A.389
C FIXHD(110) will be zero INANCA1A.390
ELSE IF(I.EQ.3) THEN INANCA1A.391
FILE_LEVELS=ST_LEVELS UJS1F401.292
ELSE IF(I.EQ.13) THEN ! for multilevel aerosols RB221193.33
FILE_LEVELS=TR_LEVELS RB221193.34
ELSE IF(I.EQ.14.or.I.EQ.16) THEN ! for murk and user ancil. GRB0F304.66
FILE_LEVELS=P_LEVELS GRB0F304.67
ELSE IF(I.EQ.17.or.I.EQ.18) THEN GDR1F401.90
! multi-level sulphur cycle ancillary files. GDR1F401.91
FILE_LEVELS=P_LEVELS GDR1F401.92
END IF INANCA1A.393
INANCA1A.394
INANCA1A.404
CL 1.4.2 Buffer in integer constants INANCA1A.405
INANCA1A.406
IF(FIXHD(100,I).GT.0) THEN INANCA1A.407
INANCA1A.408
C Check for error in file pointers INANCA1A.409
INANCA1A.410
C Check validity of integer data and print out information INANCA1A.434
C All files except ozone should contain full fields INANCA1A.435
INANCA1A.436
IF(INTHD(6,I).NE.ROW_LENGTH) THEN INANCA1A.437
C Ozone may contain zonal mean data INANCA1A.438
IF(I.NE.1.OR.INTHD(6,I).NE.1) THEN INANCA1A.439
ICODE=4 INANCA1A.440
CMESSAGE='INANCILA:integer header error' INANCA1A.441
WRITE(6,*) ' INTHD(6) : ',INTHD(6,I),' ??' UDG6F400.63
RETURN INANCA1A.442
END IF INANCA1A.443
END IF INANCA1A.444
INANCA1A.445
IF(INTHD(7,I).NE.P_ROWS.AND.(I.EQ.9.AND.INTHD INANCA1A.446
& (7,I).NE.U_ROWS)) THEN INANCA1A.447
ICODE=5 INANCA1A.448
CMESSAGE='INANCILA:integer header error' INANCA1A.449
WRITE(6,*) ' INTHD(7) : ',INTHD(7,I),' ??' UDG6F400.64
RETURN INANCA1A.450
END IF INANCA1A.451
UDG6F400.65
IF (I.EQ.1) THEN ! Ozone file UDG6F400.66
WRITE (6,*) ' ' UDG6F400.67
IF (INTHD(6,I).EQ.1)THEN UDG6F400.68
WRITE (6,*) ' OZONE file contains zonal mean data for ', UDG6F400.69
& INTHD(6,I),' points x ',INTHD(7,I),' rows' UDG6F400.70
ELSEIF (INTHD(6,I).EQ.ROW_LENGTH)THEN UDG6F400.71
WRITE (6,*) ' OZONE file contains full fields for ', UDG6F400.72
& INTHD(6,I),' points x ',INTHD(7,I),' rows' UDG6F400.73
ENDIF UDG6F400.74
! Check that correct ozone file has been provided. UDG6F400.75
IF (ZonAvOzone) THEN UDG6F400.76
IF (INTHD(6,I).NE.1) THEN UDG6F400.77
WRITE (6,*) ' Zonal Ozone Data is expected', UDG6F400.78
& ' for 1 point x ',P_ROWS,' rows' UDG6F400.79
ICODE = 51 UDG6F400.80
CMESSAGE = 'INANCA1A : Wrong Ozone data provided.' UDG6F400.81
GO TO 9999 ! Return UDG6F400.82
ENDIF UDG6F400.83
ELSE UDG6F400.84
IF (INTHD(6,I).NE.ROW_LENGTH) THEN UDG6F400.85
WRITE (6,*) ' Ozone Data is expected for ', UDG6F400.86
& ROW_LENGTH,' points x ',P_ROWS,' rows.' UDG6F400.87
ICODE = 52 UDG6F400.88
CMESSAGE = 'INANCA1A : Wrong Ozone data provided.' UDG6F400.89
GO TO 9999 ! Return UDG6F400.90
ENDIF UDG6F400.91
ENDIF UDG6F400.92
ENDIF UDG6F400.93
INANCA1A.452
END IF INANCA1A.453
INANCA1A.454
CL 1.4.3 Buffer in real constants INANCA1A.455
INANCA1A.456
IF(FIXHD(105,I).GT.0) THEN INANCA1A.457
INANCA1A.458
C Check validity of real header and print out information INANCA1A.484
INANCA1A.485
DO J=1,6 INANCA1A.486
IF(REALHD(J,I).GT.(A_REALHD(J)+0.1).OR. INANCA1A.487
& REALHD(J,I).LT.(A_REALHD(J)-0.1))THEN INANCA1A.488
IF(I.NE.1.OR.(J.NE.1.AND.J.NE.4))THEN INANCA1A.489
WRITE(6,*)(REALHD(K,I),K=1,6),(A_REALHD(K),K=1,6) INANCA1A.490
ICODE=8 INANCA1A.491
CMESSAGE='INANCILA: REAL header Error.' INANCA1A.492
RETURN INANCA1A.493
END IF INANCA1A.494
END IF INANCA1A.495
END DO INANCA1A.496
INANCA1A.497
END IF INANCA1A.498
INANCA1A.499
CL 1.4.4 Buffer in level dependent constants if required INANCA1A.500
C Not retained in model after initial check INANCA1A.501
INANCA1A.502
IF(FIXHD(110,I).GT.0) THEN INANCA1A.503
INANCA1A.504
CL Only files 1 (Ozone), and 3 (Soil temperature)should contain multi INANCA1A.517
CL level data. File 2 (Soil moisture,snow depth,fractional snow time INANCA1A.518
CL and soil moisture in layers) may possibly also have multi level data. RB221193.35
CL FILES 13,14,16 (aerosols, murkiness, user ancil.) may also have GRB0F304.68
CL multi level data. GRB0F304.69
INANCA1A.537
CL If ozone file, check against model levels INANCA1A.538
INANCA1A.539
IF(I.EQ.1) THEN INANCA1A.540
DO J=1,OZONE_LEVELS INANCA1A.541
DO J1=1,4 INANCA1A.542
IF(LNER(LEVDEPC(J+(J1-1)*FIXHD(111,I)),A_LEVDEPC INANCA1A.543
& (J+P_LEVELS-OZONE_LEVELS,J1))) THEN INANCA1A.544
WRITE(6,*)'Error in level dependent constants:Level=',J GIE0F403.274
WRITE(6,*)'Position=',J1 GIE0F403.275
WRITE(6,*)'Value in model =',A_LEVDEPC GIE0F403.276
& (J+P_LEVELS-OZONE_LEVELS,J1) INANCA1A.548
WRITE(6,*)'Value in ancillary data =',LEVDEPC(J+ GIE0F403.277
& (J1-1)*FIXHD(111,I)) INANCA1A.550
ICODE=11 INANCA1A.551
CMESSAGE='INANCILA: error in LEVDEPC.' INANCA1A.552
RETURN INANCA1A.553
END IF INANCA1A.554
END DO INANCA1A.555
END DO INANCA1A.556
INANCA1A.557
ELSE IF (I.EQ.2.OR.I.EQ.3) THEN INANCA1A.558
INANCA1A.559
IF (A_FIXHD(12).LE.0) THEN AJS1F400.48
ICODE = 121 AJS1F400.49
CMESSAGE = 'INANCA1A : FIXHD(12) not set in A_FIXHD' AJS1F400.50
WRITE (6,*) ' FIXHD(12) not set in A_FIXHD.' AJS1F400.51
WRITE (6,*) ' Run reconfiguration program to set.' AJS1F400.52
GO TO 9999 ! Return AJS1F400.53
ELSEIF (A_FIXHD(12).LT.305) THEN AJS1F400.54
JSOIL_DEPTHS = 13 AJS1F400.55
ELSE AJS1F400.56
JSOIL_DEPTHS = 6 AJS1F400.57
ENDIF AJS1F400.58
AJS1F400.59
C soil moisture levels UJS1F401.293
C AJS1F400.93
C If deep soil temperatures or multilayer soil moistures, check AJS1F400.94
C against model soil level/layer depths. AJS1F400.95
C AJS1F400.96
IF (I.EQ.2) THEN UJS1F401.294
DO J=1,SM_LEVELS UJS1F401.295
IF (LNER(LEVDEPC(J),A_LEVDEPC(J,JSOIL_DEPTHS))) THEN UJS1F401.296
ICODE=12 UJS1F401.297
CMESSAGE='INANCILA: error in LEVDEPC.' UJS1F401.298
RETURN UJS1F401.299
END IF UJS1F401.300
END DO UJS1F401.301
END IF UJS1F401.302
IF (I.EQ.3) THEN UJS1F401.303
DO J=1,ST_LEVELS UJS1F401.304
C Penman-Monteith BL version UJS1F401.305
IF(ST_LEVELS.EQ.SM_LEVELS)THEN UJS1F401.306
IF (LNER(LEVDEPC(J),A_LEVDEPC(J,JSOIL_DEPTHS)))THEN UJS1F401.307
ICODE=12 UJS1F401.308
CMESSAGE='INANCILA: error in LEVDEPC.' UJS1F401.309
RETURN UJS1F401.310
ENDIF UJS1F401.311
C All other BL versions UJS1F401.312
ELSE UJS1F401.313
IF (LNER(LEVDEPC(J),A_LEVDEPC(J+1,JSOIL_DEPTHS)))THEN UJS1F401.314
ICODE=12 UJS1F401.315
CMESSAGE='INANCILA: error in LEVDEPC.' UJS1F401.316
RETURN UJS1F401.317
END IF UJS1F401.318
END IF UJS1F401.319
END DO UJS1F401.320
END IF UJS1F401.321
INANCA1A.570
CL If aerosol file, check against model levels RB221193.38
RB221193.39
ELSE IF (I.EQ.13) THEN RB221193.40
DO J=1,TR_LEVELS RB221193.41
DO J1=1,4 GRB0F304.72
IF(LNER(LEVDEPC(J+(J1-1)*FIXHD(111,I)),A_LEVDEPC GRB0F304.73
& (J,J1))) THEN GRB0F304.74
WRITE(6,*)'Error in level dependent constants:Level=',J GIE0F403.278
WRITE(6,*)'Position=',J1 GIE0F403.279
WRITE(6,*)'Value in model =',A_LEVDEPC(J,J1) GIE0F403.280
WRITE(6,*)'Value in ancillary data =',LEVDEPC(J+ GIE0F403.281
& (J1-1)*FIXHD(111,I)) GRB0F304.79
ICODE=16 GRB0F304.80
CMESSAGE='INANCILA: error in LEVDEPC.' GRB0F304.81
RETURN GRB0F304.82
END IF GRB0F304.83
END DO GRB0F304.84
END DO GRB0F304.85
GRB0F304.86
CL If murk or user ancillary file, check against model levels GRB0F304.87
GRB0F304.88
ELSE IF (I.EQ.14.or.I.EQ.16) THEN GRB0F304.89
DO J=1,P_LEVELS GRB0F304.90
DO J1=1,4 RB221193.42
IF(LNER(LEVDEPC(J+(J1-1)*FIXHD(111,I)),A_LEVDEPC RB221193.43
& (J,J1))) THEN RB221193.44
WRITE(6,*)'Error in level dependent constants:Level=',J GIE0F403.282
WRITE(6,*)'Position=',J1 GIE0F403.283
WRITE(6,*)'Value in model =',A_LEVDEPC(J,J1) GIE0F403.284
WRITE(6,*)'Value in ancillary data =',LEVDEPC(J+ GIE0F403.285
& (J1-1)*FIXHD(111,I)) RB221193.49
ICODE=16 RB221193.50
CMESSAGE='INANCILA: error in LEVDEPC.' RB221193.51
RETURN RB221193.52
END IF RB221193.53
END DO RB221193.54
END DO RB221193.55
RB221193.56
END IF INANCA1A.571
INANCA1A.572
END IF INANCA1A.573
INANCA1A.574
CL 1.4.5 Buffer in lookup table INANCA1A.575
C Set start position of boundary fields for file INANCA1A.576
INANCA1A.577
IF(FIXHD(150,I).GT.0) THEN INANCA1A.580
INANCA1A.581
GDR7F400.24
NREC_A = 0 GDR7F400.25
NREC_S = 0 GDR7F400.26
DO J = 1,FIXHD(152,I) GDR7F400.27
IF (LOOKUP(MODEL_CODE,LOOKUPS+J) .eq. 0 .or. GDR7F400.28
& LOOKUP(MODEL_CODE,LOOKUPS+J) .eq. imdi) THEN GDR7F400.29
STASH_CODE = LOOKUP(ITEM_CODE,LOOKUPS+J) GDR7F400.30
IF ((STASH_CODE.GE.177 .and. STASH_CODE.LE.179) .or. GDR7F400.31
& (STASH_CODE.GE.210 .and. STASH_CODE.LE.212)) THEN GDR7F400.32
LOOKUP(MODEL_CODE,LOOKUPS+J) = slab_im GDR7F400.33
NREC_S = NREC_S+1 GDR7F400.34
ELSE GDR7F400.35
LOOKUP(MODEL_CODE,LOOKUPS+J) = atmos_im GDR7F400.36
NREC_A = NREC_A+1 GDR7F400.37
END IF GDR7F400.38
END IF GDR7F400.39
END DO GDR7F400.40
IF (NREC_A.GT.0) THEN GDR7F400.41
WRITE (6,*) ' ' GDR7F400.42
WRITE (6,*) ' INANCA1A : submodel_id in ',NREC_A, GDR7F400.43
& ' records set to atmos_im in ancillary file ',I GDR7F400.44
ENDIF GDR7F400.45
IF (NREC_S.GT.0) THEN GDR7F400.46
WRITE (6,*) ' ' GDR7F400.47
WRITE (6,*) ' INANCA1A : submodel_id in ',NREC_S, GDR7F400.48
& ' records set to slab_im in ancillary file ',I GDR7F400.49
ENDIF GDR7F400.50
INANCA1A.619
END IF INANCA1A.620
INANCA1A.621
LOOKUPS=LOOKUPS+FIXHD(152,I) INANCA1A.622
INANCA1A.623
ELSE INANCA1A.624
INANCA1A.625
CL If file not required, zero fixed length header INANCA1A.626
DO J=1,LEN_FIXHD INANCA1A.627
FIXHD(J,I)=0 INANCA1A.628
END DO INANCA1A.629
INANCA1A.630
LOOKUP_START(I)=LOOKUPS+1 UDG7F304.53
END IF INANCA1A.631
INANCA1A.632
END DO INANCA1A.633
INANCA1A.634
CL 1.5 Set positions in main data blocks INANCA1A.635
INANCA1A.636
*IF DEF,RECON INANCA1A.637
INANCA1A.638
ITEM=1 INANCA1A.639
DO 151 I=1,NSWITCH INANCA1A.640
IF(SWITCH(I).EQ.1)THEN INANCA1A.641
D1_ANCILADD(I)=ITEM INANCA1A.642
ITEM=ITEM+INTHD(6,FILEANCIL(I)) INANCA1A.643
* *INTHD(7,FILEANCIL(I))*LEVELS(I) INANCA1A.644
ENDIF INANCA1A.645
151 CONTINUE INANCA1A.646
INANCA1A.647
C Store address info for passing back thro argument list INANCA1A.648
DO 152 I=1,NSWITCH INANCA1A.649
D1_ANCILADD_PARM(I)=D1_ANCILADD(I) INANCA1A.650
152 CONTINUE INANCA1A.651
INANCA1A.652
*ELSE INANCA1A.653
INANCA1A.654
DO I=1,NANCIL_FIELDS INANCA1A.655
IF (MODEL_CODES_ANCIL(I).EQ.SLAB_IM) THEN GDR1F401.93
D1_ANCILADD(I)=SI_SLAB(STASHANCIL(I)) GDR8F400.92
ELSE GDR8F400.93
D1_ANCILADD(I)=SI_ATMOS(STASHANCIL(I)) GDR8F400.94
ENDIF GDR8F400.95
ENDDO INANCA1A.657
INANCA1A.658
CL 1.51 If a request is made to update a field, ensure that space for INANCA1A.659
CL that field has been allocted in D1. INANCA1A.660
INANCA1A.661
DO I=1,NANCIL_FIELDS INANCA1A.662
IF((FIELDCODE(1,I).GT.0).AND.(D1_ANCILADD(I).LE.1)) THEN INANCA1A.663
WRITE(6,*)' An address in D1 has not been set for ancillary INANCA1A.664
& field number ',I INANCA1A.665
ICODE=30 INANCA1A.666
CMESSAGE='INANCILA: updating for ancillary field is requested INANCA1A.667
& but no space has been allocated in D1' INANCA1A.668
RETURN INANCA1A.669
ENDIF INANCA1A.670
END DO INANCA1A.671
INANCA1A.672
*ENDIF INANCA1A.673
TJ240293.11
CL 1.52 Reset target STASH codes for fields mapped onto other fields TJ240293.12
CL (eg. SLAB ref SST/ice depth are obtained from normal SST and TJ240293.13
CL ice depth ancillary files as used in atmos-only mode). TJ240293.14
TJ240293.15
STASHANCIL(37)=STASHANCIL(28) ! SLAB ref SST == Normal SST TJ240293.16
STASHANCIL(38)=STASHANCIL(29) ! SLAB ref icedep == Normal icedep TJ240293.17
INANCA1A.674
CL 1.6 Set positions of data INANCA1A.675
INANCA1A.676
DO I=1,NANCIL_FIELDS INANCA1A.677
NLOOKUP(I) =0 ADR1F304.112
LOOKUP_STEP(I)=0 ADR1F304.113
ADR1F304.114
C If LOOKUP_START=0 for file FILEANCIL(I), no fields required. ADR1F304.115
IF (LOOKUP_START(FILEANCIL(I)).GT.0) THEN ADR1F304.116
ADR1F304.117
DO J=LOOKUP_START(FILEANCIL(I)),LOOKUPS INANCA1A.678
DR211293.12
IF (LOOKUP(ITEM_CODE,J).EQ.STASHANCIL(I)) THEN INANCA1A.680
NLOOKUP(I)=J-LOOKUP_START(FILEANCIL(I))+1 INANCA1A.681
GOTO 161 INANCA1A.682
END IF INANCA1A.683
INANCA1A.684
END DO INANCA1A.685
INANCA1A.686
C Find second occurence of data to set LOOKUP_STEP INANCA1A.687
INANCA1A.688
161 LOOKUP_STEP(I)=0 INANCA1A.689
INANCA1A.690
INANCA1A.691
IF(J.LT.LOOKUPS) THEN INANCA1A.692
INANCA1A.693
DO J1=J+LEVELS(I),LOOKUPS INANCA1A.694
IF (LOOKUP(ITEM_CODE,J1).EQ.STASHANCIL(I)) THEN INANCA1A.695
LOOKUP_STEP(I)=J1-NLOOKUP(I)-LOOKUP_START(FILEANCIL(I))+1 INANCA1A.696
GOTO 164 INANCA1A.697
END IF INANCA1A.698
END DO INANCA1A.699
164 CONTINUE INANCA1A.700
END IF ADR1F304.118
ADR1F304.119
END IF INANCA1A.701
INANCA1A.702
END DO INANCA1A.703
INANCA1A.704
CL SET LEVELS=2 FOR ICE FRACTION AND SNOW DEPTH, TO INDICATE PRESCENCE INANCA1A.705
CL fractional time fields INANCA1A.706
INANCA1A.707
LEVELS(27)=2 INANCA1A.708
LEVELS(9)=2 INANCA1A.709
INANCA1A.710
900 CONTINUE INANCA1A.711
9999 CONTINUE UDG6F400.94
RETURN INANCA1A.712
END INANCA1A.713
*ENDIF INANCA1A.714