SUBROUTINE INITCTL( 1,12@DYALLOC.1429
& NUM_STASH_LEVELSDA,NUM_LEVEL_LISTSDA, @DYALLOC.1430
& NITEMS_DA,NSECTS_DA,NMDLS_DA, GSS1F305.232
*CALL ARGSIZE 
@DYALLOC.1431
*CALL ARGSTS @DYALLOC.1432
*CALL ARGPPX GSS1F305.233
*CALL ARGD1 GSM2F403.234
& ICODE,CMESSAGE) @DYALLOC.1433
INITCTL1.26
IMPLICIT NONE INITCTL1.27
INITCTL1.28
*CALL CSUBMODL ! Defines N_INTERNAL_MODEL to dimension STASH arrays GSS1F305.234
GSS1F305.235
CL Arguments GSS1F305.236
GSS1F305.237
*CALL TYPSIZE @DYALLOC.1436
*CALL TYPSTS ! Contains *CALL CPPXREF GSS1F305.238
*CALL PPXLOOK ! Contains *CALL VERSION GSS3F401.40
INTEGER @DYALLOC.1438
& NUM_STASH_LEVELSDA, ! IN: Extra copy for portable @DYALLOC.1439
& NUM_LEVEL_LISTSDA, ! IN: dynamic allocation @DYALLOC.1440
& NITEMS_DA, ! IN: Local copy, other in common without _DA GMC2F304.5
& NSECTS_DA, ! IN: Local copy, other in common without _DA GMC2F304.6
& NMDLS_DA, GSS1F305.241
& ICODE ! OUT: Error return code @DYALLOC.1441
C @DYALLOC.1442
CHARACTER*256 @DYALLOC.1443
& CMESSAGE ! OUT: Error return message @DYALLOC.1444
INITCTL1.32
*CALL CHSUNITS RS030293.118
*CALL CCONTROL INITCTL1.33
*CALL CLOOKADD @DYALLOC.1445
*CALL CHISTORY GDR3F305.137
*CALL STPARAM INITCTL1.38
*CALL C_MDI INITCTL1.39
*CALL CSTASH GRB0F401.18
*CALL STEXTEND ! Declares arrays used in STASH_PROC code (LIST_S etc.); GSS1F305.244
! also contains common block STEXTEND GSS1F305.245
*CALL TYPD1 ! For accessing D1 addressing array GSM2F403.235
INITCTL1.40
C External subroutines called INITCTL1.41
INITCTL1.42
INTEGER EXPPXI GSS1F305.246
CHARACTER*36 EXPPXC GSS1F305.247
GSS1F305.248
EXTERNAL INITCTL1.43
& DIAGDESC,TIMER,EXPPXI,EXPPXC GRB2F400.16
& ,FILL_D1_ARRAY GSM2F403.236
INITCTL1.45
C Local arrays GMC2F304.7
GSS1F305.250
! STASH input lengths GSS1F305.251
INTEGER SI_LEN(NITEMS_DA,0:NSECTS_DA,NMDLS_DA) GSS1F305.252
INTEGER ppxref_dat(PPXREF_CODELEN) GSS1F305.253
GSS1F305.254
C Local variables INITCTL1.46
INITCTL1.47
CHARACTER*36 NAME GSS1F305.255
REAL INITCTL1.48
& REAL_LEVELS(NUM_STASH_LEVELSDA,NUM_LEVEL_LISTSDA) @DYALLOC.1446
INITCTL1.50
INTEGER INITCTL1.51
& NUM_LISTS, INITCTL1.53
& NUM_LEVELS, INITCTL1.54
& NUM_PSEUDO_LEVELS, GSS1F305.256
& N_TABLES, INITCTL1.56
& I, INITCTL1.57
& IPK, GSS1F305.257
& KK, GSS1F305.258
& L, GSS1F305.259
& IS, INITCTL1.58
& IE, INITCTL1.59
& II, INITCTL1.60
& SM, GSM2F403.237
& IOBJ, GSM2F403.238
& ISEC, GSM2F403.239
& ITM, GSM2F403.240
& Im_ident, GSM2F403.241
& Sm_ident, GSM2F403.242
& IX, MC261093.57
& ISTEP, INITCTL1.61
& IL, INITCTL1.62
& IM, INITCTL1.63
& JJ, INITCTL1.64
& INPUT_LENGTH INITCTL1.65
GSS1F305.260
INTEGER IR1 ! loop start GSS1F400.1387
INTEGER IR,J,K ! loop count GSS1F400.1388
CHARACTER*1 VAR_TYPE GSS1F400.1389
CHARACTER*80 FILENAME AD050293.158
LOGICAL INT_MOD_INCLUDED ! Flag to indicate whether a particular GSS1F305.261
! internal model is included GSS1F305.262
INITCTL1.77
!----------------------------------------------------------------------- GSS1F305.263
INITCTL1.82
! 1. Assign STASHlist and associated lists to appropriate UM arrays GSS1F305.264
GSS1F305.265
! Initialise STLIST to zero GSS1F305.266
GSS1F305.267
DO II = 1,TOTITEMS GSS1F305.268
DO IE = 1,LEN_STLIST GSS1F305.269
STLIST(IE,II)=0 INITCTL1.85
END DO INITCTL1.86
END DO INITCTL1.87
INITCTL1.90
! Assign STASH list to STLIST GSS1F305.270
INITCTL1.96
DO I = 1,TOTITEMS GSS1F305.271
DO J = 1,LEN_STLIST GSS1F305.272
STLIST(J,I) = LIST_S(J,I) GSS1F305.273
END DO GSS1F305.274
END DO INITCTL1.103
INITCTL1.104
! Assign STASH times tables to STTABL GSS1F305.275
INITCTL1.106
DO I = 1,NSTTABL GSS1F305.276
DO J = 1,NSTTIMS GSS1F305.277
STTABL(J,I) = ITIM_S(J,I) GSS1F305.278
END DO GSS1F305.279
END DO INITCTL1.119
INITCTL1.120
! Assign STASH levels lists to STASH_LEVELS GSS1F305.280
INITCTL1.123
DO II=1,NUM_LEVEL_LISTS ! Initialise STASH_LEVELS to -99 GSS1F305.281
DO JJ=1,NUM_STASH_LEVELS+1 INITCTL1.125
STASH_LEVELS(JJ,II)=-99 INITCTL1.126
END DO GSS1F305.282
END DO GSS1F305.283
INITCTL1.145
DO I = 1,NUM_LEVEL_LISTS GSS1F305.284
NUM_LEVELS = LEVLST_S(1,I) GSS1F305.285
STASH_LEVELS(1,I) = NUM_LEVELS GSS1F305.286
DO J = 1,NUM_LEVELS GSS1F305.287
IF (LLISTTY(I).EQ.'R') THEN GSS1F305.288
REAL_LEVELS (J ,I) = RLEVLST_S (J+1,I) GSS1F305.289
STASH_LEVELS(J+1,I) =(REAL_LEVELS(J ,I)+0.0001)*1000.0 GSS1F305.290
ELSE IF (LLISTTY(I).EQ.'I') THEN GSS1F305.291
STASH_LEVELS(J+1,I) = LEVLST_S (J+1,I) GSS1F305.292
END IF GSS1F305.293
END DO GSS1F305.294
END DO GSS1F305.295
INITCTL1.148
! Store STASH pseudo levels lists in STASH_PSEUDO_LEVELS GSS1F305.296
GSS1F305.297
DO II=1,NUM_PSEUDO_LISTS ! Initialise STASH_PSEUDO_LEVELS GSS1F305.298
DO JJ=1,NUM_STASH_PSEUDO+1 ! to -99 GSS1F305.299
STASH_PSEUDO_LEVELS(JJ,II)=-99 INITCTL1.151
ENDDO INITCTL1.152
ENDDO INITCTL1.153
INITCTL1.161
DO I = 1,NUM_PSEUDO_LISTS GSS1F305.300
NUM_LEVELS = LENPLST(I) GSS1F305.301
STASH_PSEUDO_LEVELS(1,I) = NUM_LEVELS GSS1F305.302
DO J = 1,NUM_LEVELS GSS1F305.303
STASH_PSEUDO_LEVELS(J+1,I) = PSLIST_D(J,I) GSS1F305.304
END DO INITCTL1.205
END DO INITCTL1.206
INITCTL1.207
!Transfer time series data to STASH_SERIES array GSS1F400.1390
IF (NSERIES.GT.0) THEN GSS1F400.1391
!There are timeseries domains GSS1F400.1392
! Loop over STASHC domain profiles GSS1F400.1393
DO I=1,NDPROF GSS1F400.1394
IF (NPOS_TS(I) .GT. 0) THEN GSS1F400.1395
! This domain profile has a block of time series domains GSS1F400.1396
! J=time series block identifier (pointer): GSS1F400.1397
J=NPOS_TS(I) GSS1F400.1398
! STASH_SERIES_INDEX(1,J)=sequence no. of first record for GSS1F400.1399
! ts block J in STASH_SERIES GSS1F400.1400
IF (J.EQ.1) THEN GSS1F400.1401
STASH_SERIES_INDEX(1,J)=1 GSS1F400.1402
ELSE GSS1F400.1403
STASH_SERIES_INDEX(1,J)= STASH_SERIES_INDEX(1,J-1) GSS1F400.1404
& +STASH_SERIES_INDEX(2,J-1) GSS1F400.1405
END IF GSS1F400.1406
! STASH_SERIES_INDEX(2,J)=no. of records in ts block J GSS1F400.1407
STASH_SERIES_INDEX(2,J)=NRECS_TS(J) GSS1F400.1408
IR1 =STASH_SERIES_INDEX(1,J) GSS1F400.1409
DO IR=IR1,IR1+NRECS_TS(J)-1 GSS1F400.1410
STASH_SERIES(1,IR)=IG_TS GSS1F400.1411
STASH_SERIES(2,IR)=I1_TS GSS1F400.1412
STASH_SERIES(3,IR)=I51_TS GSS1F400.1413
STASH_SERIES(4,IR)=NLIM_TS(IR) GSS1F400.1414
STASH_SERIES(5,IR)=SLIM_TS(IR) GSS1F400.1415
STASH_SERIES(6,IR)=WLIM_TS(IR) GSS1F400.1416
STASH_SERIES(7,IR)=ELIM_TS(IR) GSS1F400.1417
STASH_SERIES(8,IR)=BLIM_TS(IR) GSS1F400.1418
STASH_SERIES(9,IR)=TLIM_TS(IR) GSS1F400.1419
END DO GSS1F400.1420
END IF GSS1F400.1421
END DO GSS1F400.1422
END IF GSS1F400.1423
GSS1F305.341
! Initialise STINDEX and SI GSS1F305.342
GSS1F305.343
DO IE=1,NITEMS GSS1F305.344
DO IS=0,NSECTS INITCTL1.208
DO IM=1,N_INTERNAL_MODEL GSS1F305.345
DO II=1,2 GSS1F305.346
STINDEX(II,IE,IS,IM)=0 GSS1F305.347
END DO INITCTL1.211
SI (IE,IS,IM)=1 GSS1F305.348
SI_LEN(IE,IS,IM)=0 GSS1F305.349
IF (IS.EQ.0) THEN GSS1F305.350
PPINDEX(IE,IM)=0 GSS1F305.351
END IF GSS1F305.352
END DO GSS1F305.353
END DO GSS1F305.354
END DO INITCTL1.212
INITCTL1.213
! 2. Read STASHindex and compute STASHWORK array lengths. GSS1F305.355
! The Lth. row in STINDEX, SI, SI_LEN, PPINDEX, corresponds to the GSS1F305.356
! Lth. internal model in INTERNAL_MODEL_LIST. GSS1F305.357
! Output a formatted description of the selected diagnostics. GSS1F305.358
GSS1F305.359
ii =0 ! Counter for checking no. of diags. printed GSS1F305.360
L =0 ! Counter for rows in STINDEX, SI, etc. GSS1F305.361
DO K=1,N_INTERNAL_MODEL_MAX GSS1F305.362
INT_MOD_INCLUDED=.FALSE. GSS3F401.41
! Find out whether int. model 'K' is included. If it is: GSS1F305.366
! Set logical flag, increment row number GSS1F305.367
DO KK=1,N_INTERNAL_MODEL_MAX GSS1F305.369
IF (INTERNAL_MODEL_LIST(KK).EQ.K) THEN GSS1F305.370
INT_MOD_INCLUDED=.TRUE. GSS1F305.371
L = L + 1 GSS1F305.372
END IF GSS1F305.373
END DO MC261093.61
IF (INT_MOD_INCLUDED) THEN GSS1F305.374
DO J=0,NSECTS ! NSECTS=NSECTP (WSTLST) GSS1F305.375
DO I=1,NITEMS ! NITEMS=NITEMP (WSTLST) GSS1F305.376
IF (IN_S(1,K,J,I).GE.1) THEN ! Entry in STASH list GSS1F305.377
ii = ii + 1 GSS1F305.379
STINDEX(1,I,J,L) = INDX_S (1,K,J,I) ! STASH index GSS1F305.380
STINDEX(2,I,J,L) = INDX_S (2,K,J,I) GSS1F305.381
SI ( I,J,L) = IN_S (1,K,J,I) ! STASH lengths and GSS1F305.382
SI_LEN ( I,J,L) = IN_S (2,K,J,I) ! addresses in D1 GSS1F305.383
IF (J.EQ.0 .AND. PPIND_S(K,I).NE.0) THEN GSS1F305.384
PPINDEX(I, L) = PPIND_S( K, I) ! Index for pp header GSS1F305.385
END IF ! array GSS1F305.386
! Extract ppxref information to be passed into GSS1F305.387
! diagnostic description routine GSS1F305.388
NAME = EXPPXC(K,J,I, GSS1F305.389
*CALL ARGPPX GSS1F305.390
& ICODE,CMESSAGE) GSS1F305.391
ppxref_dat(ppx_model_number) = K GSS3F401.42
ppxref_dat(ppx_field_code ) = EXPPXI(K,J,I,ppx_field_code , GSS1F305.394
*CALL ARGPPX GSS1F305.395
& ICODE,CMESSAGE) GSS1F305.396
ppxref_dat(ppx_data_type ) = EXPPXI(K,J,I,ppx_data_type , GSS1F305.397
*CALL ARGPPX GSS1F305.398
& ICODE,CMESSAGE) GSS1F305.399
ppxref_dat(ppx_grid_type ) = EXPPXI(K,J,I,ppx_grid_type , GSS1F305.400
*CALL ARGPPX GSS1F305.401
& ICODE,CMESSAGE) GSS1F305.402
ppxref_dat(ppx_lv_code ) = EXPPXI(K,J,I,ppx_lv_code , GSS1F305.403
*CALL ARGPPX GSS1F305.404
& ICODE,CMESSAGE) GSS1F305.405
ppxref_dat(ppx_cf_levelcode) = EXPPXI(K,J,I,ppx_cf_levelcode, GSS1F305.406
*CALL ARGPPX GSS1F305.407
& ICODE,CMESSAGE) GSS1F305.408
ppxref_dat(ppx_cf_fieldcode) = EXPPXI(K,J,I,ppx_cf_fieldcode, GSS1F305.409
*CALL ARGPPX GSS1F305.410
& ICODE,CMESSAGE) GSS1F305.411
DO IPK = 0,9 GSS1F305.412
ppxref_dat(ppx_pack_acc+IPK) = EXPPXI(K,J,I,ppx_pack_acc+IPK, GSS1F305.413
*CALL ARGPPX GSS1F305.414
& ICODE,CMESSAGE) GSS1F305.415
END DO GSS1F305.416
GSS1F305.417
! Write a formatted description of the diagnostic to output file. GSS1F305.418
DO IX=STINDEX(1,I,J,L), ! Loop over GSS1F305.420
& STINDEX(1,I,J,L)+STINDEX(2,I,J,L)-1 ! entries GSS1F305.421
IF (LTIMER) CALL TIMER('DIAGDESC',3) MC261093.93
CALL DIAGDESC(IX,NAME,STLIST(1,IX),ppxref_dat(1), GSS1F305.423
& stash_levels,num_stash_levels,num_level_lists, MC261093.95
& stash_pseudo_levels,num_stash_pseudo,num_pseudo_lists, MC261093.96
& sttabl,nsttims,nsttabl, MC261093.97
& stash_series,time_series_rec_len,nstash_series_records, MC261093.98
& stash_series_index,nstash_series_block) MC261093.99
IF (LTIMER) CALL TIMER('DIAGDESC',4) MC261093.100
ENDDO GSS1F305.424
ELSE IF (IN_S(1,K,J,I).EQ.-1) THEN GSM4F404.12
ii = ii + 1 GSM4F404.13
END IF ! INDX_S(1,K,J,I).GE.1 GSS1F305.425
IF (ICODE.GT.0) GOTO 999 GSS1F305.426
END DO ! Items GSS1F305.427
END DO ! Sections GSS1F305.428
IF (K.EQ.A_IM) THEN GSS3F401.43
! Set SI for thetal from that for theta, and QT from that for Q GSS3F401.44
! - different item numbers but same address GSS3F401.45
SI( 5,0,L) = SI( 4,0,L) GSS3F401.46
SI(11,0,L) = SI(10,0,L) GSS3F401.47
END IF GSS3F401.48
END IF ! INT_MOD_INCLUDED GSS1F305.429
END DO ! Models GSS1F305.430
GSS1F305.431
IF (ii.NE.N_PPXRECS) THEN GSS1F305.432
WRITE(6,*) ' Error in INITCTL: N_PPXRECS not correct ',II MC261093.106
CMESSAGE='INITCTL : N_PPXRECS not correct ' MC261093.107
ICODE=1 MC261093.108
GOTO 999 MC261093.109
END IF MC261093.110
INITCTL1.241
!Assign values to PP_LEN2_LOOK, FT_OUTPUT GSS1F305.433
DO I = 20,NUNITS GSS1F305.434
PP_LEN2_LOOK(I)=PPlen2LkUp(I) GSS1F305.435
FT_OUTPUT (I)=FTOutUnit (I) GSS1F305.436
END DO GSS1F305.437
GSS1F305.438
INITCTL1.248
CL 2.1 Find the max length in STASH_WORK and store in STASH_MAXLEN INITCTL1.249
INITCTL1.250
DO IM=1,N_INTERNAL_MODEL GSS1F305.441
DO IS=1,NSECTS ! Note not section Zero as the data is in D1 INITCTL1.251
STASH_MAXLEN(IS,IM)=1 GSS1F305.442
DO IE=1,NITEMS ! Again only data not in D1 MC261093.111
IF(STINDEX(1,IE,IS,IM).NE.0) THEN GSS1F305.443
C Item is in STASHlist ... MC261093.112
IF (STLIST(st_input_code,STINDEX(1,IE,IS,IM)).EQ.1) THEN GSS1F305.444
C ... and input from STASHwork MC261093.114
C ... input length not from ST_LIST as this is post STOCGT GMC2F304.12
INPUT_LENGTH=SI_LEN(IE,IS,IM) GSS1F305.445
STASH_MAXLEN(IS,IM)=STASH_MAXLEN(IS,IM)+INPUT_LENGTH GSS1F305.446
ENDIF MC261093.117
ENDIF INITCTL1.257
END DO INITCTL1.258
END DO GSS1F305.447
END DO INITCTL1.259
INITCTL1.260
CL INITCTL1.261
CL MC261093.118
CL---------------------------------------------------------------------- INITCTL1.287
CL 3. Set derived control variables for use in STASH/STWORK GSS1F305.448
CL INITCTL1.289
CL Set PP_LEN2_LOOKUP to maximum PP_LEN2_LOOK value for any PP GSS1F305.449
CL unit referenced in the STASHlist (minimum value possible is 8). INITCTL1.291
CL Set MAX_STASH_LEVS to the maximum possible no of output levels INITCTL1.292
CL for any diagnostic, allowing for possible pseudo-levels. INITCTL1.293
CL INITCTL1.294
PP_LEN2_LOOKUP=8 INITCTL1.295
MAX_STASH_LEVS=1 GSS1F305.450
DO II=1,TOTITEMS GSS1F305.451
IF (STLIST(st_output_code,II).LT.0) THEN INITCTL1.298
C output is to PP file INITCTL1.299
IF (PP_LEN2_LOOK(-STLIST(st_output_code,II)) INITCTL1.300
& .GT.PP_LEN2_LOOKUP) INITCTL1.301
& PP_LEN2_LOOKUP=PP_LEN2_LOOK(-STLIST(st_output_code,II)) INITCTL1.302
ENDIF INITCTL1.303
C GSS1F305.452
C Input levels list/range is always longer than output GSS1F305.453
IF (STLIST(st_input_bottom,II).EQ.st_special_code) THEN GSS1F305.454
C On special level GSS1F305.455
NUM_LEVELS=1 GSS1F305.456
ELSE IF (STLIST(st_input_bottom,II).LT.0) THEN GSS1F305.457
C Using levels list, element 1 holds length. GSS1F305.458
NUM_LEVELS=STASH_LEVELS(1,-STLIST(st_input_bottom,II)) GSS1F305.459
ELSE GSS1F305.460
C Range GSS1F305.461
NUM_LEVELS= GSS1F305.462
& STLIST(st_input_top,II)-STLIST(st_input_bottom,II)+1 GSS1F305.463
END IF GSS1F305.464
IF (STLIST(st_pseudo_in,II).NE.0) THEN GSS1F305.465
C On pseudo levels GSS1F305.466
NUM_PSEUDO_LEVELS=STASH_PSEUDO_LEVELS(1, GSS1F305.467
& STLIST(st_pseudo_in,II)) GSS1F305.468
ELSE GSS1F305.469
C Not on pseudo levels GSS1F305.470
NUM_PSEUDO_LEVELS=1 GSS1F305.471
END IF GSS1F305.472
MAX_STASH_LEVS=MAX(MAX_STASH_LEVS,NUM_LEVELS*NUM_PSEUDO_LEVELS) GSS1F305.473
END DO INITCTL1.311
C Round PP_LEN2_LOOKUP up to a multiple of 8 INITCTL1.312
PP_LEN2_LOOKUP=((PP_LEN2_LOOKUP+7)/8)*8 INITCTL1.313
GSM2F403.243
GSM2F403.244
CALL FILL_D1_ARRAY( GSM2F403.245
*CALL ARGSIZE GSM2F403.246
*CALL ARGSTS GSM2F403.247
*CALL ARGPPX GSM2F403.248
*CALL ARGD1 GSM2F403.249
& ICODE,CMESSAGE) GSM2F403.250
GSM2F403.251
GSM2F403.252
C---------------------------------------------------------------------- GSM2F403.253
999 CONTINUE GSM2F403.254
RETURN GSM2F403.255
END GSM2F403.256
GSM2F403.257
CLL SUBROUTINE FILL_D1_ARRAY------------------------------------------ GSM2F403.258
CLL GSM2F403.259
CLL PURPOSE: Fill D1 addressing array with useful information. GSM2F403.260
CLL S.D.Mullerworth GSM2F403.261
GSM2F403.262
SUBROUTINE FILL_D1_ARRAY( 1,1GSM2F403.263
*CALL ARGSIZE GSM2F403.264
*CALL ARGSTS GSM2F403.265
*CALL ARGPPX GSM2F403.266
*CALL ARGD1 GSM2F403.267
& ICODE,CMESSAGE) GSM2F403.268
GSM2F403.269
IMPLICIT NONE GSM2F403.270
GSM2F403.271
*CALL CSUBMODL GSM2F403.272
*CALL TYPSIZE GSM2F403.273
*CALL TYPSTS ! Contains *CALL CPPXREF GSM2F403.274
*CALL PPXLOOK ! Contains *CALL VERSION GSM2F403.275
*CALL CHSUNITS GSM2F403.276
*CALL CHISTORY GSM2F403.277
*CALL STPARAM GSM2F403.278
*CALL C_MDI GSM2F403.279
*CALL CSTASH GSM2F403.280
*CALL MODEL GSM2F403.281
*CALL STEXTEND ! Declares arrays used in STASH_PROC code (LIST_S etc.); GSM2F403.282
! also contains common block STEXTEND GSM2F403.283
*CALL TYPD1 ! For accessing D1 addressing array GSM2F403.284
GSM2F403.285
INTEGER GSM2F403.286
& II, ! Addresses preliminary array GSM2F403.287
& SM, ! Addresses final array=1 for 1st submod =2 for 2nd GSM2F403.288
& ! submodel etc GSM2F403.289
& TYPE, ! Code for prognostic, diagnostic, secondary or other GSM2F403.290
& IOBJ, ! Addresses final array GSM2F403.291
& ISEC, ! Section number GSM2F403.292
& ITM, ! Item number GSM2F403.293
& LEVS, ! No of levels GSM2F403.294
& INF, ! Diagnostic STASHlist number or prognosic item number GSM2F403.295
& Im_ident, GSM2F403.296
& Sm_ident, GSM2F403.297
& LOOKUP_PTR, ! Pointer to lookup table GSM2F403.298
& EXT_ADDR, ! Temporary pointer GSM2F403.299
& ICODE ! OUT: Error return code GSM2F403.300
C GSM2F403.301
CHARACTER*256 GSM2F403.302
& CMESSAGE ! OUT: Error return message GSM2F403.303
GSM2F403.304
INTEGER EXPPXI GSM2F403.305
EXTERNAL EXPPXI GSM2F403.306
GSM2F403.307
C Initialise array GSM2F403.308
DO Sm_ident=1,N_SUBMODEL_PARTITION GSM2F403.309
DO II=1,N_OBJ_D1_MAX GSM2F403.310
DO INF=1,D1_LIST_LEN GSM2F403.311
D1_ADDR(INF,II,Sm_ident)=-1 GSM2F403.312
NO_OBJ_D1(Sm_ident)=0 GSM2F404.184
ENDDO GSM2F403.313
ENDDO GSM2F403.314
ENDDO GSM2F403.315
GSM2F403.316
C Set up addressing of D1 GSM2F403.317
WRITE(6,*)'Addressing of D1 array' GSM2F403.318
WRITE(6,*)'Key to Type:' GSM2F403.319
WRITE(6,*)'Type=0: Prognostic' GSM2F403.320
WRITE(6,*)'Type=1: Diagnostics in dump' GSM2F403.321
WRITE(6,*)'Type=2: Secondary diagnostics' GSM2F403.322
WRITE(6,*)'Type=3: Others (eg P_EXNER in atmos or 2nd of dual ' GSM2F403.323
WRITE(6,*)' time level ocean fields)' GSM2F403.324
SM=0 GSM2F403.325
DO Sm_ident=1,N_SUBMODEL_PARTITION_MAX GSM2F403.326
IOBJ=0 GSM2F403.327
SM=SUBMODEL_FOR_SM(Sm_ident) GSM2F403.328
IF (SM.NE.0) THEN GSM2F403.329
IF (NO_OBJ_D1(SM).EQ.0) THEN GSM2F404.185
NO_OBJ_D1(SM)=N_OBJ_D1(Sm_ident) GSM2F403.330
WRITE(6,*)'Submodel id ',Sm_ident GJC0F405.24
WRITE(6,*)'Submodel Number ',SM GJC0F405.25
WRITE(6,*)'No of objects in this submodel: ',NO_OBJ_D1(SM) GSM2F404.186
! Address if submodel not empty and not already addressed GSM2F404.187
DO II=1,NO_OBJ_D1(SM) GSM2F403.334
C Preliminary array held in D1_PADDR - full array in D1_ADDR GSM2F403.335
C Index II in D1_PADDR goes into index IOBJ of D1_ADDR GSM2F403.336
C First add prognostics followed by diagnostics... GSM2F403.337
Im_ident=D1_PADDR(d1_im,II,Sm_ident) GSM2F403.338
INF=D1_PADDR(d1_extra_info,II,Sm_ident) GSM2F403.339
TYPE=D1_PADDR(d1_type,II,Sm_ident) GSM2F403.340
IF (TYPE.EQ.prog) THEN GSM2F403.341
IOBJ=IOBJ+1 GSM2F403.342
D1_ADDR(d1_stlist_no,IOBJ,SM)=INF GSM2F403.343
D1_ADDR(d1_no_levels,IOBJ,SM)= GSM2F403.344
& D1_PADDR(d1_levs,II,Sm_ident) GSM2F403.345
D1_ADDR(d1_object_type,IOBJ,SM)=prognostic GSM2F403.346
D1_ADDR(d1_imodl,IOBJ,SM) = Im_ident GSM2F403.347
D1_ADDR(d1_address,IOBJ,SM)= IN_S(1,Im_ident,0,INF) GSM2F403.348
ELSEIF (TYPE.EQ.diag) THEN GSM2F403.349
IOBJ=IOBJ+1 GSM2F403.350
D1_ADDR(d1_stlist_no,IOBJ,SM)=INF GSM2F403.351
D1_ADDR(d1_object_type,IOBJ,SM)=diagnostic GSM2F403.352
D1_ADDR(d1_imodl,IOBJ,SM) = Im_ident GSM2F403.353
D1_ADDR(d1_address,IOBJ,SM)= STLIST(st_output_addr,INF) GSM2F403.354
ENDIF GSM2F403.355
ENDDO GSM2F403.356
C Calculate end position of progs and diags for ocean GSM2F403.357
IF(SM_IDENT.EQ.O_SM)THEN GSM2F403.358
EXT_ADDR=LPrimIM(O_IM)+LDumpIM(O_IM)+1 GSM2F403.359
ENDIF GSM2F403.360
GSM2F403.361
C Extra data between primary and secondary diagnostics GSM2F403.362
DO II=1,NO_OBJ_D1(SM) GSM2F403.363
TYPE=D1_PADDR(d1_type,II,Sm_ident) GSM2F403.364
IF (TYPE.EQ.extra_d1) THEN GSM2F403.365
Im_ident=D1_PADDR(d1_im,II,Sm_ident) GSM2F403.366
INF=D1_PADDR(d1_extra_info,II,Sm_ident) GSM2F403.367
IOBJ=IOBJ+1 GSM2F403.368
D1_ADDR(d1_stlist_no,IOBJ,SM)=INF GSM2F403.369
D1_ADDR(d1_no_levels,IOBJ,SM)= GSM2F403.370
& D1_PADDR(d1_levs,II,Sm_ident) GSM2F403.371
D1_ADDR(d1_object_type,IOBJ,SM)=other GSM2F403.372
D1_ADDR(d1_imodl,IOBJ,SM) = Im_ident GSM2F403.373
IF(SM_IDENT.NE.O_IM)THEN GSM2F403.374
C NOT OCEAN: Address was calculated in ADDRES GSM2F403.375
D1_ADDR(d1_address,IOBJ,SM)= IN_S(1,Im_ident,0,INF) GSM2F403.376
ELSE GSM2F403.377
C OCEAN: This is first time 2nd timestep prognostics GSM2F403.378
C have been addressed so calculate GSM2F403.379
D1_ADDR(d1_address,IOBJ,SM)=EXT_ADDR GSM2F403.380
EXT_ADDR=EXT_ADDR+IN_S(2,Im_ident,0,INF) GSM2F403.381
ENDIF GSM2F403.382
ENDIF GSM2F403.383
ENDDO GSM2F403.384
C Finally add secondary diagnostics GSM2F403.385
DO II=1,NO_OBJ_D1(SM) GSM2F403.386
C Preliminary array held in D1_PADDR - full array in D1_ADDR GSM2F403.387
Im_ident=D1_PADDR(d1_im,II,Sm_ident) GSM2F403.388
INF=D1_PADDR(d1_extra_info,II,Sm_ident) GSM2F403.389
TYPE=D1_PADDR(d1_type,II,Sm_ident) GSM2F403.390
IF (TYPE.EQ.seco) THEN GSM2F403.391
IOBJ=IOBJ+1 GSM2F403.392
D1_ADDR(d1_stlist_no,IOBJ,SM)=INF GSM2F403.393
D1_ADDR(d1_object_type,IOBJ,SM)=secondary GSM2F403.394
D1_ADDR(d1_imodl,IOBJ,SM) = Im_ident GSM2F403.395
D1_ADDR(d1_address,IOBJ,SM)= STLIST(st_output_addr,INF) GSM2F403.396
ENDIF GSM2F403.397
ENDDO GSM2F403.398
GSM2F403.399
LOOKUP_PTR=0 GSM2F403.400
DO II=1,NO_OBJ_D1(SM) GSM2F403.401
TYPE= D1_ADDR(d1_object_type,II,SM) GSM2F403.402
INF = D1_ADDR(d1_stlist_no,II,SM) GSM2F403.403
Im_ident = D1_ADDR(d1_imodl,II,SM) GSM2F403.404
IF((TYPE.EQ.prognostic).OR.(TYPE.EQ.other))THEN GSM2F403.405
C Prognostics don't have STASHlist numbers GSM2F403.406
D1_ADDR(d1_stlist_no,II,SM)= -1 GSM2F403.407
D1_ADDR(d1_section,II,SM)= 0 GSM2F403.408
D1_ADDR(d1_item,II,SM) = INF GSM2F403.409
D1_ADDR(d1_length,II,SM) = IN_S(2,Im_ident,0,INF) GSM2F403.410
ISEC = 0 GSM2F403.411
ITM = INF GSM2F403.412
C------------------------------------------------------------------- GSM2F403.413
C Prognostic items: GSM2F403.414
C Additional items can be added to the array here. Its code (eg GSM2F403.415
C d1_item, d1_levels) should be added to the TYPD1 comdeck and GSM2F403.416
C set as a parameter. The D1_LIST_LEN parameter should be changed GSM2F403.417
C as required GSM2F403.418
C------------------------------------------------------------------- GSM2F403.419
ELSE GSM2F403.420
D1_ADDR(d1_section,II,SM)= STLIST(st_sect_code,INF) GSM2F403.421
D1_ADDR(d1_item,II,SM) = STLIST(st_item_code,INF) GSM2F403.422
D1_ADDR(d1_length,II,SM) = STLIST(st_output_length,INF) GSM2F403.423
ISEC=D1_ADDR(d1_section,II,SM) GSM2F403.424
ITM=D1_ADDR(d1_item,II,SM) GSM2F403.425
C STASH list pointer to D1 address information GSM2F403.426
STLIST(st_position_in_d1,INF) = II GSM2F403.427
C------------------------------------------------------------------- GSM2F403.428
C Diagnostic items GSM2F403.429
C Add items as per prognostics GSM2F403.430
C------------------------------------------------------------------- GSM2F403.431
D1_ADDR(d1_north_code,II,SM) =STLIST(st_north_code,INF) GSM2F403.432
D1_ADDR(d1_south_code,II,SM) =STLIST(st_south_code,INF) GSM2F403.433
D1_ADDR(d1_east_code,II,SM) =STLIST(st_east_code,INF) GSM2F403.434
D1_ADDR(d1_west_code,II,SM) =STLIST(st_west_code,INF) GSM2F403.435
D1_ADDR(d1_gridpoint_code,II,SM)=STLIST(s_grid,INF) GSM2F403.436
D1_ADDR(d1_proc_no_code,II,SM) =STLIST(s_proc,INF) GSM2F403.437
C 1. Number of levels GSM2F403.438
IF(STLIST(st_output_bottom,INF).EQ.100) THEN GSM2F403.439
C Special levels GSM2F403.440
LEVS=1 GSM2F403.441
ELSE IF(STLIST(st_series_ptr,INF).NE.0) THEN GSM2F403.442
C Time series domain GSM2F403.443
LEVS=1 GSM2F403.444
ELSE IF(STLIST(st_gridpoint_code,INF).GE.10 GSM2F403.445
& .AND.STLIST(st_gridpoint_code,INF).LT.20) THEN GSM2F403.446
C Vertical ave. GSM2F403.447
LEVS=1 GSM2F403.448
ELSE IF(STLIST(st_output_bottom,INF).LT.0) THEN GSM2F403.449
C Levels list GSM2F403.450
LEVS=LEVLST_S(1,-STLIST(st_output_bottom,INF)) GSM2F403.451
ELSE GSM2F403.452
C Range of model levels GSM2F403.453
LEVS=STLIST(st_output_top ,INF) GSM2F403.454
& -STLIST(st_output_bottom,INF)+1 GSM2F403.455
END IF GSM2F403.456
GSM2F403.457
IF (STLIST(st_pseudo_out,INF).GT.0) THEN GSM2F403.458
C Pseudo levels GSM2F403.459
LEVS=LEVS*LENPLST(STLIST(st_pseudo_out,INF)) GSM2F403.460
END IF GSM2F403.461
D1_ADDR(d1_no_levels,II,SM) = LEVS GSM2F403.462
ENDIF GSM2F403.463
C------------------------------------------------------------------- GSM2F403.464
C Items whose settings are common to progs and diags (eg from PPXREF) GSM2F403.465
C Add items as per prognostics GSM2F403.466
C ISEC and ITM set above GSM2F403.467
C------------------------------------------------------------------- GSM2F403.468
D1_ADDR(d1_grid_type,II,SM) = GSM2F403.469
& EXPPXI(Im_ident,ISEC,ITM,ppx_grid_type, GSM2F403.470
*CALL ARGPPX GSM2F403.471
& ICODE, CMESSAGE) GSM2F403.472
LOOKUP_PTR=LOOKUP_PTR+D1_ADDR(d1_no_levels,II,SM) GSM2F403.473
D1_ADDR(d1_lookup_ptr,II,SM)=LOOKUP_PTR GSM2F403.474
ENDDO GSM2F403.475
WRITE(6,*) GSM2F403.476
&' Type Modl Sect Item Address Length Levels Gridtype' GSM2F403.477
DO II=1,NO_OBJ_D1(SM) GSM2F403.478
WRITE(6,100)II,D1_ADDR(d1_object_type,II,SM), GSM2F403.479
& D1_ADDR(d1_imodl,IOBJ,SM), GSM2F403.480
& D1_ADDR(d1_section,II,SM),D1_ADDR(d1_item,II,SM), GSM2F403.481
& D1_ADDR(d1_address,II,SM),D1_ADDR(d1_length,II,SM), GSM2F403.482
& D1_ADDR(d1_no_levels,II,SM),D1_ADDR(d1_grid_type,II,SM) GSM2F403.483
GSM2F403.484
ENDDO GSM2F403.485
100 FORMAT(5I5,I8,2I7,I5) GSM2F403.486
ENDIF ! IF (NO_OBJ_D1(SM).EQ.0) THEN GSM2F404.188
ENDIF GSM2F403.487
GSM2F403.488
ENDDO ! DO Sm_ident=1,N_SUBMODEL_PARTITION_MAX GSM2F403.489
INITCTL1.314
999 CONTINUE INITCTL1.315
RETURN INITCTL1.316
END INITCTL1.317
INITCTL1.318
*ENDIF INITCTL1.319