*IF DEF,CONTROL INANCCT1.2
C ******************************COPYRIGHT****************************** GTS2F400.4501
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.4502
C GTS2F400.4503
C Use, duplication or disclosure of this code is subject to the GTS2F400.4504
C restrictions as set forth in the contract. GTS2F400.4505
C GTS2F400.4506
C Meteorological Office GTS2F400.4507
C London Road GTS2F400.4508
C BRACKNELL GTS2F400.4509
C Berkshire UK GTS2F400.4510
C RG12 2SZ GTS2F400.4511
C GTS2F400.4512
C If no contract has been raised with this copy of the code, the use, GTS2F400.4513
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.4514
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.4515
C Modelling at the above address. GTS2F400.4516
C ******************************COPYRIGHT****************************** GTS2F400.4517
C GTS2F400.4518
CLL Subroutine INANCCTL INANCCT1.3
CLL INANCCT1.4
CLL Control routine for CRAY YMP INANCCT1.5
CLL INANCCT1.6
CLL Model Modification history from model version 3.0: INANCCT1.7
CLL version date INANCCT1.8
CLL 3.1 2/02/93 : added comdeck CHSUNITS to define NUNITS for i/o RS030293.109
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.69
CLL portability. Author Tracey Smith. TS150793.70
CLL 3.2 27/03/93 Dynamic allocation of main data arrays. R. Rawlins @DYALLOC.1231
CLL 3.3 22/11/93 Add unit nos. 110,48 for source terms & aerosols. RB221193.58
CLL 3.3 26/10/93 M. Carter. Part of an extensive mod that: MC261093.42
CLL 1.Removes the limit on primary STASH item numbers. MC261093.43
CLL 2.Removes the assumption that (section,item) MC261093.44
CLL defines the sub-model. MC261093.45
CLL 3.Thus allows for user-prognostics. MC261093.46
CLL Remove reference to A/O_MAX_VARIABLES MC261093.47
CLL 3.4 16/06/94 Arguments LANCILA, LANCILO added GSS1F304.349
CLL DEFs ANCILA, ANCILO replaced by LOGICALS GSS1F304.350
CLL LANCILA, LANCILO GSS1F304.351
CLL CALLs to INANCILA/O now controlled by DEFs ATMOS, GSS1F304.352
CLL OCEAN as well as logical switches LANCILA/O GSS1F304.353
CLL Argument LCAL360 added and passed to INANCILA GSS1F304.354
CLL S.J.Swarbrick GSS1F304.355
CLL 3.4 20/07/94 Initialise reference time for interpolation of GRB1F304.9
CLL ancillaries. R.T.H.Barnes GRB1F304.10
CLL 3.4 04/08/94 O_LEVDEPC passed to INANCILO. Mike Bell. GMB1F304.5
CLL 3.4 05/09/94 Add unit nos.111-114 for user ancillaries. RTHBarnes GRB0F304.91
CLL 3.4 05/10/94 Add unit nos.109 for murk ancillary. RTHBarnes GRB0F304.92
CLL 3.5 07/06/95 Chgs to SI array. RTHBarnes GRB4F305.235
CLL 4.0 19/10/95 Pass A_FIXHD to INANCILA. D. Robinson AJS1F400.121
CLL 4.0 06/01/96 Pass SI for atmos and slab internal models to GDR8F400.48
CLL INANCA1A for SLAB runs. D. Robinson GDR8F400.49
CLL 4.1 17/04/96 Introduce wave sub-model. RTHBarnes. WRB1F401.149
! 4.1 18/06/96 Changes to cope with changes in STASH addressing GDG0F401.782
! Author D.M. Goddard. GDG0F401.783
CLL 4.1 22/05/96 Call new CANC* comdecks. D. Robinson. GDR1F401.61
!LL 4.3 18/03/97 In MPP mode pass global sizes to INANCILA/O/W ARB2F403.159
!LL for checking against INTHD. R.T.H.Barnes. ARB2F403.160
!LL 4.4 03/11/97 New argument LCAL360 to INANCILO. D. Robinson. ODR1F404.93
!LL 4.5 19/01/98 Remove SOIL_VARS and VEG_VARS. D. Robinson. GDR6F405.8
!LL 4.5 11/09/98 Put DEFs round routines in EXTERNAL. D. Robinson. GHM2F405.1
!LL 4.5 05/05/98 Improve error message for missing files. R. Rawlins GRR1F405.1
CLL INANCCT1.9
CLL Programming standard; Unified Model Documentation Paper No. 3 INANCCT1.10
CLL draft version no. 3, dated 12/7/89 INANCCT1.11
CLL INANCCT1.12
CLL System components covered : C710 INANCCT1.13
CLL INANCCT1.14
CLL System task : C7 INANCCT1.15
CLL INANCCT1.16
CLL Purpose : Takes as input,the code defining the frequency of update INANCCT1.17
CLL of ancillary fields as set by the user interface. INANCCT1.18
CLL Converts them into a list of numbers of timesteps after INANCCT1.19
CLL which each field must be updated, and calculates the INANCCT1.20
CLL frequency with which this list must be interogated. INANCCT1.21
CLL Where the update interval is in months or years, INANCCT1.22
CLL the check will be carried out each day. The physical INANCCT1.23
CLL files required are also determined by input code, INANCCT1.24
CLL and the headers and lookup tables are read into INANCCT1.25
CLL COMMON/ANCILHDA/ or COMMON/ANCILHDO/ (*COMDECK CANCIL) INANCCT1.26
CLL INANCCT1.27
CLL Documentation : Unified Model Documentation Paper No C7 INANCCT1.28
CLL Version No.4 dated 15/06/90 INANCCT1.29
CLLEND INANCCT1.30
SUBROUTINE INANCCTL( 1,5@DYALLOC.1232
*CALL ARGSIZE 
@DYALLOC.1233
*CALL ARGDUMA @DYALLOC.1234
*CALL ARGDUMO @DYALLOC.1235
*CALL ARGDUMW WRB1F401.150
*CALL ARGSTS @DYALLOC.1236
*CALL ARGPTRA @DYALLOC.1237
*CALL ARGPTRO @DYALLOC.1238
*CALL ARGPTRW WRB1F401.151
*CALL ARGANC @DYALLOC.1239
*CALL ARGPPX GDG0F401.784
& ICODE,CMESSAGE) GDR3F305.225
INANCCT1.35
C* INANCCT1.36
IMPLICIT NONE INANCCT1.37
C*L Arguments @DYALLOC.1241
CL @DYALLOC.1242
*CALL CSUBMODL GDR3F305.226
*CALL TYPSIZE @DYALLOC.1243
*CALL TYPDUMA @DYALLOC.1244
*CALL TYPDUMO @DYALLOC.1245
*CALL TYPDUMW WRB1F401.152
*CALL TYPSTS @DYALLOC.1246
*CALL TYPPTRA @DYALLOC.1247
*CALL TYPPTRO @DYALLOC.1248
*CALL TYPPTRW WRB1F401.153
*CALL TYPANC @DYALLOC.1249
*CALL PPXLOOK GDG0F401.785
@DYALLOC.1250
C*L INANCCT1.38
INTEGER INANCCT1.39
& ICODE ! Out return code :0 Nor al Exit INANCCT1.40
C ! :>0 Error INANCCT1.41
INANCCT1.42
CHARACTER*80 TS150793.71
& CMESSAGE ! Out error message if ICODE >0 INANCCT1.44
INANCCT1.45
C* INANCCT1.46
INANCCT1.47
*CALL CHSUNITS RS030293.110
*CALL CMAXSIZE GDR3F305.227
*CALL CCONTROL GDR3F305.228
*CALL CLOOKADD INANCCT1.50
*CALL CTIME INANCCT1.53
*IF DEF,MPP ARB2F403.161
*CALL PARVARS ARB2F403.162
*CALL DECOMPTP ARB2F403.163
*ENDIF ARB2F403.164
INANCCT1.54
INANCCT1.55
! Comdecks for ancillary files/fields. GDR1F401.62
*CALL CANCFTNA GDR1F401.63
*CALL CANCFTNO GDR1F401.64
*CALL CANCFTNW GDR1F401.65
*CALL CANCTITA GDR1F401.66
GDR1F401.67
CL External subroutines called: INANCCT1.56
INANCCT1.57
*IF DEF,ATMOS GHM2F405.2
EXTERNAL INANCILA GHM2F405.3
*ENDIF GHM2F405.4
*IF DEF,OCEAN GHM2F405.5
EXTERNAL INANCILO GHM2F405.6
*ENDIF GHM2F405.7
*IF DEF,WAVE GHM2F405.8
EXTERNAL INANCILW GHM2F405.9
*ENDIF GHM2F405.10
INANCCT1.61
C Local variables INANCCT1.62
INTEGER IM_IDENT ! internal model identifier GRB4F305.236
INTEGER IM_INDEX ! internal model index for STASH arrays GRB4F305.237
INTEGER IM_INDEX_S ! as IM_INDEX for Slab Model GDR8F400.50
INTEGER I INANCCT1.63
INTEGER STEPS_PER_HR ! steps per hour for atmos/wave sub_models WRB1F401.156
*IF DEF,MPP ARB2F403.165
INTEGER decomp_type ! domain decomposition type ARB2F403.166
*ENDIF ARB2F403.167
INANCCT1.66
INANCCT1.69
CL initialise reference time for time interpolation of ancillaries. GRB1F304.11
IF ( ANCIL_REFTIME(1).eq.0 .and. ANCIL_REFTIME(2).eq.0 GRB1F304.12
&.and.ANCIL_REFTIME(3).eq.0 .and. ANCIL_REFTIME(4).eq.0 GRB1F304.13
&.and.ANCIL_REFTIME(5).eq.0 .and. ANCIL_REFTIME(5).eq.0 ) THEN GRB1F304.14
WRITE(6,*)' ANCIL_REFTIME set same as MODEL_BASIS_TIME' GIE0F403.286
ANCIL_REFTIME(1) = MODEL_BASIS_TIME(1) GRB1F304.16
ANCIL_REFTIME(2) = MODEL_BASIS_TIME(2) GRB1F304.17
ANCIL_REFTIME(3) = MODEL_BASIS_TIME(3) GRB1F304.18
ANCIL_REFTIME(4) = MODEL_BASIS_TIME(4) GRB1F304.19
ANCIL_REFTIME(5) = MODEL_BASIS_TIME(5) GRB1F304.20
ANCIL_REFTIME(6) = MODEL_BASIS_TIME(6) GRB1F304.21
WRITE(6,*)' ANCIL_REFTIME = MODEL_BASIS_TIME = ',ANCIL_REFTIME GIE0F403.287
ELSE GRB1F304.23
WRITE(6,*)' ANCIL_REFTIME set by User Interface = ',ANCIL_REFTIME GIE0F403.288
END IF GRB1F304.25
GRB1F304.26
*IF DEF,ATMOS GSS1F304.359
C Set up internal model identifier and STASH index GRB4F305.238
im_ident = atmos_im GRB4F305.239
im_index = internal_model_index(im_ident) GRB4F305.240
*IF DEF,MPP ARB2F403.168
! Check that current decomposition is correct for ancillaries ARB2F403.169
! for this sub-model ARB2F403.170
decomp_type=decomp_standard_atmos ARB2F403.171
IF (current_decomp_type .NE. decomp_type) THEN ARB2F403.172
CALL CHANGE_DECOMPOSITION(decomp_type,icode) ARB2F403.173
IF (icode .gt. 0) THEN ARB2F403.174
WRITE(6,*) 'INANCCTL : Error' ARB2F403.175
WRITE(6,*) 'Call to CHANGE_DECOMPOSITION failed with ', ARB2F403.176
& 'decomposition type ',decomp_type ARB2F403.177
CMESSAGE='INANCCTL;Unsupported decomposition for MPP code' ARB2F403.178
GOTO 999 ARB2F403.179
END IF ARB2F403.180
END IF ARB2F403.181
*ENDIF ARB2F403.182
*IF DEF,SLAB GDR8F400.51
im_ident = slab_im GDR8F400.52
im_index_s = internal_model_index(im_ident) GDR8F400.53
*ENDIF GDR8F400.54
INANCCT1.71
CL Initialise Fortran file numbers INANCCT1.72
DO I=1,NANCIL_DATASETSA INANCCT1.73
FTNANCILA(I)=FTN_ANCIL_A(I) GDR1F401.68
ENDDO INANCCT1.75
STEPS_PER_HR = 3600*STEPS_PER_PERIODim(a_im)/ WRB1F401.157
& SECS_PER_PERIODim(a_im) GDR3F305.232
INANCCT1.76
CALL INANCILA (LEN_FIXHD,PP_LEN_INTHD,PP_LEN_REALHD,A_LEN1_LEVDEPC INANCCT1.77
& ,A_LEN2_LEVDEPC,FIXHD_ANCILA,INTHD_ANCILA, INANCCT1.78
& REALHD_ANCILA,LOOKUP_ANCILA, AJS1F400.122
& A_FIXHD,A_REALHD,A_LEVDEPC, AJS1F400.123
& NANCIL_DATASETSA,NANCIL_LOOKUPSA,FTNANCILA, INANCCT1.80
& LOOKUP_START_ANCILA,LEN1_LOOKUP, ARB2F403.183
*IF DEF,MPP ARB2F403.184
& glsize(1),glsize(2),glsize(2)-1, ARB2F403.185
*ELSE ARB2F403.186
& ROW_LENGTH,P_ROWS,U_ROWS, ARB2F403.187
*ENDIF ARB2F403.188
& P_LEVELS,TR_LEVELS, ARB2F403.189
& ST_LEVELS,SM_LEVELS,OZONE_LEVELS, AJS1F401.1562
& TITLE_ANCIL_A, GDR1F401.69
! all prognostics assumed to be in section 0 GDR8F400.55
& SI(1,0,im_index), ! SI for atmos_im, sect 0 GDR8F400.56
*IF DEF,SLAB GDR8F400.57
& SI(1,0,im_index_s), ! SI for slab_im, sect 0 GDR8F400.58
*ELSE GDR8F400.59
& SI(1,0,im_index), ! SI for atmos_im, sect 0 GDR8F400.60
*ENDIF GDR8F400.61
& NITEMS, GDR8F400.62
& ANCILLARY_STEPSim(a_im),STEPS_PER_HR, WRB1F401.158
*CALL ARGPPX WRB1F401.159
& ICODE,CMESSAGE,LCAL360) GSS1F304.361
GRR1F405.2
IF(ICODE.GT.0) THEN GRR1F405.3
write(6,*) 'INANCCTL: Error return from INANCILA ',ICODE GRR1F405.4
write(6,*) CMESSAGE GRR1F405.5
GO TO 999 ! Jump to end of routine GRR1F405.6
ENDIF GRR1F405.7
INANCCT1.87
*IF DEF,SLAB GDR8F400.63
IF (ANCILLARY_STEPSim(a_im).GT.0) THEN GDR8F400.64
ANCILLARY_STEPSim(s_im) = GDR8F400.65
& ANCILLARY_STEPSim(a_im)/STEPS_PER_PERIODim(a_im) GDR8F400.66
write (6,*) ' ANCILLARY_STEPSim(s_im) ',ANCILLARY_STEPSim(s_im) GDR8F400.67
ENDIF GDR8F400.68
*ENDIF GDR8F400.69
GDR8F400.70
*ENDIF INANCCT1.88
INANCCT1.89
*IF DEF,OCEAN GSS1F304.363
C Set up internal model identifier and STASH index GRB4F305.242
im_ident = ocean_im GRB4F305.243
im_index = internal_model_index(im_ident) GRB4F305.244
*IF DEF,MPP,AND,DEF,ATMOS ARB2F403.190
! For coupled ocean/atmos model, check that current decomposition ARB2F403.191
! is correct for ancillaries for this sub-model ARB2F403.192
decomp_type=decomp_standard_ocean ARB2F403.193
IF (current_decomp_type .NE. decomp_type) THEN ARB2F403.194
CALL CHANGE_DECOMPOSITION(decomp_type,icode) ARB2F403.195
IF (icode .gt. 0) THEN ARB2F403.196
WRITE(6,*) 'INANCCTL : Error' ARB2F403.197
WRITE(6,*) 'Call to CHANGE_DECOMPOSITION failed with ', ARB2F403.198
& 'decomposition type ',decomp_type ARB2F403.199
CMESSAGE='INANCCTL;Unsupported decomposition for MPP code' ARB2F403.200
GOTO 999 ARB2F403.201
END IF ARB2F403.202
END IF ARB2F403.203
*ENDIF ARB2F403.204
INANCCT1.91
CL Initialise Fortran file numbers INANCCT1.92
DO I=1,NANCIL_DATASETSO INANCCT1.93
FTNANCILO(I)=FTN_ANCIL_O(I) GDR1F401.70
ENDDO INANCCT1.95
INANCCT1.96
CALL INANCILO (LEN_FIXHD,PP_LEN_INTHD,PP_LEN_REALHD,O_LEN1_LEVDEPC INANCCT1.97
& ,FIXHD_ANCILO,INTHD_ANCILO, INANCCT1.98
& REALHD_ANCILO,LOOKUP_ANCILO,O_REALHD, O_LEVDEPC, GMB1F304.6
& NANCIL_DATASETSO,NANCIL_LOOKUPSO,FTNANCILO, INANCCT1.100
& LOOKUP_START_ANCILO,LEN1_LOOKUP, ARB2F403.205
*IF DEF,MPP ARB2F403.206
& glsize(1),glsize(2), ARB2F403.207
*ELSE ARB2F403.208
& IMT,JMT, ARB2F403.209
*ENDIF ARB2F403.210
& SI(1,0,im_index),NITEMS, ! assumes prognostics are in section 0 GRB4F305.245
& ANCILLARY_STEPSim(o_im),STEPS_PER_PERIODim(o_im), GDR3F305.236
& SECS_PER_PERIODim(o_im), GDR3F305.237
*CALL ARGPPX GDG0F401.786
& LCAL360,ICODE,CMESSAGE) ODR1F404.94
GRR1F405.8
IF(ICODE.GT.0) THEN GRR1F405.9
write(6,*) 'INANCCTL: Error return from INANCILO ',ICODE GRR1F405.10
write(6,*) CMESSAGE GRR1F405.11
GO TO 999 ! Jump to end of routine GRR1F405.12
ENDIF GRR1F405.13
INANCCT1.106
*ENDIF INANCCT1.107
WRB1F401.160
*IF DEF,WAVE WRB1F401.161
C Set up internal model identifier and STASH index WRB1F401.162
im_ident = wave_im WRB1F401.163
im_index = internal_model_index(im_ident) WRB1F401.164
WRB1F401.165
CL Initialise Fortran file numbers WRB1F401.166
DO I=1,NANCIL_DATASETSW WRB1F401.167
FTNANCILW(I)=FTN_ANCIL_W(I) WRB1F401.168
ENDDO WRB1F401.169
STEPS_PER_HR = 3600*STEPS_PER_PERIODim(w_im)/ WRB1F401.170
& SECS_PER_PERIODim(w_im) WRB1F401.171
WRB1F401.172
WRITE(6,*)' INANCCTL; INANCILW routine newly written' GIE0F403.289
CALL INANCILW (LEN_FIXHD,PP_LEN_INTHD,PP_LEN_REALHD,W_LEN1_LEVDEPC WRB1F401.174
& ,W_LEN2_LEVDEPC,FIXHD_ANCILW,INTHD_ANCILW, WRB1F401.175
& REALHD_ANCILW,LOOKUP_ANCILW,W_FIXHD,W_REALHD, WRB1F401.176
& W_LEVDEPC,NANCIL_DATASETSW,NANCIL_LOOKUPSW, WRB1F401.177
& FTNANCILW,LOOKUP_START_ANCILW,LEN1_LOOKUP, ARB2F403.211
*IF DEF,MPP ARB2F403.212
& glsize(1),glsize(2), ARB2F403.213
*ELSE ARB2F403.214
& NGX,NGY, ARB2F403.215
*ENDIF ARB2F403.216
& SI(1,0,im_index),NITEMS, ! assumes prognostics are in section 0 WRB1F401.179
& ANCILLARY_STEPSim(w_im),STEPS_PER_HR, WRB1F401.180
*CALL ARGPPX WRB1F401.181
& ICODE,CMESSAGE,LCAL360) WRB1F401.182
GRR1F405.14
IF(ICODE.GT.0) THEN GRR1F405.15
write(6,*) 'INANCCTL: Error return from INANCILW ',ICODE GRR1F405.16
write(6,*) CMESSAGE GRR1F405.17
GO TO 999 ! Jump to end of routine GRR1F405.18
ENDIF GRR1F405.19
WRB1F401.183
*ENDIF WRB1F401.184
999 CONTINUE ARB2F403.217
RETURN INANCCT1.108
END INANCCT1.109
*ENDIF INANCCT1.111