SUBROUTINE PRELIM(NRECS, 1,43PRELIM1.7
*CALL ARGPPX 
PRELIM1.8
& NTIMES,NLEVELS,ErrorStatus,CMESSAGE) GSS1F400.1222
IMPLICIT NONE PRELIM1.10
PRELIM1.11
! Description: PRELIM1.12
! Constructs a preliminary STASH list of user requests. Uses interim PRELIM1.13
! pointer system, by means of the "extra entry" NELEMP+1 in the LIST_S PRELIM1.14
! array. At this stage, the input levels encompass all possible levels. PRELIM1.15
! Called by STPROC. PRELIM1.16
! PRELIM1.17
! Method: PRELIM1.18
! PRELIM1.19
! Current code owner: S.J.Swarbrick PRELIM1.20
! PRELIM1.21
! History: PRELIM1.22
! Version Date Comment PRELIM1.23
! ======= ==== ======= PRELIM1.24
! 3.5 Mar. 95 Original code. S.J.Swarbrick PRELIM1.25
! 4.1 Apr. 96 Numerous improvements associated with wave model, GSS3F401.797
! correction of output-times table processing, GSS3F401.798
! comprehensive soft-abort system, etc. GSS3F401.799
! S.J.Swarbrick GSS3F401.800
! 4.4 Sep. 97 Allow offset for sampling frequency GSM5F404.5
! S.D. Mullerworth GSM5F404.6
!LL 4.4 21/11/96 Allow daily mean timeseries. R.A.Stratton GRS1F404.1
! 4.4 Oct. 97 Added checking of error returns from TOTIMP. GDW1F404.187
! Shaun de Witt GDW1F404.188
! 4.5 18/11/98 Allow new sampling frequencies for vegetation. ABX1F405.1
! Richard Betts ABX1F405.2
! PRELIM1.26
! Code description: PRELIM1.27
! FORTRAN 77 + common Fortran 90 extensions. PRELIM1.28
! Written to UM programming standards version 7. PRELIM1.29
! PRELIM1.30
! System component covered: PRELIM1.31
! System task: Sub-Models Project PRELIM1.32
! PRELIM1.33
! Global variables: PRELIM1.34
PRELIM1.35
*CALL CSUBMODL PRELIM1.36
*CALL CPPXREF GSS3F401.801
*CALL PPXLOOK GSS3F401.802
*CALL TYPSIZE GSS3F401.803
*CALL CSTASH GRB0F401.19
*CALL STEXTEND PRELIM1.39
*CALL MODEL PRELIM1.40
*CALL CNTLATM GSS3F401.804
*CALL STPARAM PRELIM1.43
PRELIM1.44
! Subroutine arguments PRELIM1.45
PRELIM1.46
PRELIM1.50
! Scalar arguments with intent(out): PRELIM1.51
PRELIM1.52
INTEGER NRECS PRELIM1.53
INTEGER NTIMES PRELIM1.54
INTEGER NLEVELS ! Total no. of sets of levs for diags (inpt+outp) PRELIM1.55
CHARACTER*80 CMESSAGE GSS9F402.172
PRELIM1.56
! ErrorStatus: PRELIM1.57
INTEGER ErrorStatus PRELIM1.58
PRELIM1.59
! Local scalars: PRELIM1.60
LOGICAL MODEL_LEV GSS3F401.805
LOGICAL LMASK PRELIM1.62
LOGICAL LMEAN PRELIM1.63
LOGICAL LOFFSET PRELIM1.64
INTEGER TOTIMP PRELIM1.65
INTEGER I PRELIM1.66
INTEGER IBOT1 PRELIM1.67
INTEGER IDIAG PRELIM1.68
INTEGER IDOMLEV PRELIM1.69
INTEGER IDOM_L PRELIM1.70
LOGICAL LDUM PRELIM1.71
INTEGER IFIRST PRELIM1.72
INTEGER IFIRST1 PRELIM1.73
INTEGER ILAST PRELIM1.74
INTEGER ILAST1 PRELIM1.75
INTEGER IM PRELIM1.76
INTEGER IMD PRELIM1.77
INTEGER IPLOF PRELIM1.78
INTEGER MODL_L PRELIM1.79
INTEGER ISEC_L PRELIM1.80
INTEGER ITEM_L PRELIM1.81
INTEGER ITIM_L PRELIM1.82
INTEGER ITIM PRELIM1.83
INTEGER ITOP1 PRELIM1.84
INTEGER IUSE_L PRELIM1.85
INTEGER IX1 PRELIM1.86
INTEGER IX2 PRELIM1.87
INTEGER IY1 PRELIM1.88
INTEGER IY2 PRELIM1.89
INTEGER JLEV PRELIM1.90
INTEGER LEV_OFFSET PRELIM1.91
INTEGER LBVC PRELIM1.92
PRELIM1.95
! Function and subroutine calls: PRELIM1.96
LOGICAL DISCT_LEV GSS3F401.806
INTEGER EXPPXI PRELIM1.98
EXTERNAL EXPPXI,LEVSRT,TSTMSK,LLTORC,LEVCOD,PSLCOM,PSLIMS PRELIM1.99
PRELIM1.100
!- End of Header ------------------------------------------------------ PRELIM1.101
PRELIM1.102
! 0.1 Store output-times tables in array ITIM_S PRELIM1.103
PRELIM1.104
IF(NTIMES.EQ.0) THEN GSS3F401.807
DO I=1,NPROFTP PRELIM1.106
IF (IOPT_T(I).EQ.2.AND.MODL_T(I).GT.0) THEN GSS3F401.808
! Profile has output times list GSS3F401.809
! MODL_T(I) labels internal model for times list GSS3F401.810
DO ITIM=1,ITIM_T(I) PRELIM1.109
ITIM_S(ITIM,I)=TOTIMP(ISER_T(ITIM,I),UNT3_T(I),MODL_T(I)) GSS3F401.811
if (ITIM_S(ITIM,I) .eq. -999) then GDW1F404.189
ErrorStatus = 100 GDW1F404.190
cmessage = 'TOTIMP:UNEXPECTED TIME UNIT or '// GDW1F404.191
& 'IRREGULAR DUMPS FOR DUMP FREQUENCY' GDW1F404.192
GOTO 9999 GDW1F404.193
endif GDW1F404.194
END DO PRELIM1.111
ITIM_S(ITIM_T(I)+1,I)=-1 PRELIM1.112
ELSE PRELIM1.113
ITIM_S(1,I)=-1 PRELIM1.114
END IF PRELIM1.115
END DO PRELIM1.116
NTIMES=NPROFTP GSS3F401.812
END IF PRELIM1.133
PRELIM1.135
! 0.2 Store output levels lists in array LEVLST_S PRELIM1.136
PRELIM1.137
LEV_OFFSET=NLEVELS ! Initialised to 0 before entering this routine PRELIM1.138
PRELIM1.139
! Loop over domain profiles in STASH basis file PRELIM1.140
DO I=1,NDPROF PRELIM1.141
IF (LEVB_D(I).EQ.-1) THEN PRELIM1.142
! There is a levels list for this dom prof PRELIM1.143
IF (IOPL_D(I).EQ.1.OR.IOPL_D(I).EQ.2.OR. PRELIM1.144
& IOPL_D(I).EQ.6 ) THEN PRELIM1.145
! Levs list contains model levs - list type is integer PRELIM1.146
LLISTTY(I+LEV_OFFSET)='I' PRELIM1.147
ELSE PRELIM1.148
! Not model levs - list type real PRELIM1.149
LLISTTY(I+LEV_OFFSET)='R' PRELIM1.150
END IF PRELIM1.151
! LEVT_D(I) = no. of levs in list 'I' PRELIM1.152
LEVLST_S(1,I+LEV_OFFSET)=LEVT_D(I) PRELIM1.153
PRELIM1.154
! Levels list 'I' was read into (R)LEVLST_D(J,I), J=1,LEVT_D(I), PRELIM1.155
! by RDBASIS. PRELIM1.156
! Transfer this levels list to (R)LEVLST_S(J,I+LEV_OFFSET), PRELIM1.157
! J=2,LEVT_D(I)+1. PRELIM1.158
PRELIM1.159
DO JLEV=1,LEVT_D(I) PRELIM1.160
IF (IOPL_D(I).EQ.1.OR.IOPL_D(I).EQ.2.OR. PRELIM1.161
& IOPL_D(I).EQ.6 ) THEN PRELIM1.162
! Model levels PRELIM1.163
LEVLST_S(JLEV+1,I+LEV_OFFSET)= LEVLST_D(JLEV,I) PRELIM1.164
ELSE IF (IOPL_D(I).NE.5) THEN PRELIM1.165
! Real levels PRELIM1.166
RLEVLST_S(JLEV+1,I+LEV_OFFSET)=RLEVLST_D(JLEV,I) PRELIM1.167
END IF PRELIM1.168
END DO PRELIM1.169
PRELIM1.170
IPLOF=I+LEV_OFFSET PRELIM1.171
PRELIM1.172
! Sort this levels list into correct order (if not already in order) PRELIM1.173
CALL LEVSRT( LLISTTY( IPLOF), LEVLST_S(1,IPLOF), PRELIM1.174
& LEVLST_S(2,IPLOF),RLEVLST_S(2,IPLOF)) PRELIM1.175
ELSE PRELIM1.176
! No levels list, i.e., the output from this diag. is on a PRELIM1.177
! contiguous range of model levels PRELIM1.178
LEVLST_S(1,I+LEV_OFFSET)=0 PRELIM1.179
END IF PRELIM1.180
END DO ! Domain profiles PRELIM1.181
PRELIM1.182
NLEVELS=NDPROF+LEV_OFFSET ! NDPROF = no. of sets of input levels PRELIM1.183
PRELIM1.184
IF(NLEVELS.GT.NLEVLSTSP) THEN PRELIM1.185
WRITE(6,*) PRELIM1.186
& 'PRELIM: TOO MANY LEVELS LISTS, ARRAYS OVERWRITTEN' PRELIM1.187
CMESSAGE= GSS1F400.1224
& 'PRELIM: TOO MANY LEVELS LISTS, ARRAYS OVERWRITTEN' GSS1F400.1225
GO TO 9999 GSS1F400.1226
END IF PRELIM1.189
PRELIM1.190
! Section 1. MAIN LOOP - loop over diag requests in STASH basis file PRELIM1.191
PRELIM1.192
IF(NDIAG.GT.0) THEN PRELIM1.193
PRELIM1.194
DO IDIAG=1,NDIAG PRELIM1.195
PRELIM1.196
MODL_L=MODL_B(IDIAG) PRELIM1.197
ISEC_L=ISEC_B(IDIAG) PRELIM1.198
ITEM_L=ITEM_B(IDIAG) PRELIM1.199
IDOM_L=IDOM_B(IDIAG) PRELIM1.200
IUSE_L=IUSE_B(IDIAG) PRELIM1.201
ITIM_L=ITIM_B(IDIAG) PRELIM1.202
PRELIM1.203
IF(ITIM_L.NE.0) THEN ! If the diag is not a null request PRELIM1.204
PRELIM1.205
! Section 1.0 Extract data required for STASH processing from PPXI PRELIM1.206
PRELIM1.207
IF(NRECS.EQ.NRECDP) THEN PRELIM1.208
WRITE(6,*) PRELIM1.209
& 'MESSAGE FROM ROUTINE PRELIM: ', GSS3F401.813
& 'TOO MANY STASH LIST ENTRIES, REQUEST DENIED' GSS3F401.814
WRITE(6,*) 'MODEL,SECTION,ITEM ', GSS1F400.1227
& MODL_L,ISEC_L,ITEM_L GSS1F400.1228
GOTO 999 PRELIM1.212
END IF PRELIM1.213
PRELIM1.214
VMSK = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_version_mask , PRELIM1.215
*CALL ARGPPX PRELIM1.216
& ErrorStatus,CMESSAGE) PRELIM1.217
ISPACE = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_space_code , PRELIM1.218
*CALL ARGPPX PRELIM1.219
& ErrorStatus,CMESSAGE) PRELIM1.220
ITIMA = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_timavail_code, PRELIM1.221
*CALL ARGPPX PRELIM1.222
& ErrorStatus,CMESSAGE) PRELIM1.223
IGP = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_grid_type , PRELIM1.224
*CALL ARGPPX PRELIM1.225
& ErrorStatus,CMESSAGE) PRELIM1.226
ILEV = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_lv_code , PRELIM1.227
*CALL ARGPPX PRELIM1.228
& ErrorStatus,CMESSAGE) PRELIM1.229
IBOT = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_lb_code , PRELIM1.230
*CALL ARGPPX PRELIM1.231
& ErrorStatus,CMESSAGE) PRELIM1.232
ITOP = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_lt_code , PRELIM1.233
*CALL ARGPPX PRELIM1.234
& ErrorStatus,CMESSAGE) PRELIM1.235
IFLAG = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_lev_flag , PRELIM1.236
*CALL ARGPPX PRELIM1.237
& ErrorStatus,CMESSAGE) PRELIM1.238
DO I=1,4 GSS3F401.815
IOPN(I) = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_opt_code+I-1 , GSS3F401.816
*CALL ARGPPX PRELIM1.240
& ErrorStatus,CMESSAGE) PRELIM1.241
END DO GSS3F401.817
IPSEUDO = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_pt_code , PRELIM1.242
*CALL ARGPPX PRELIM1.243
& ErrorStatus,CMESSAGE) PRELIM1.244
IPFIRST = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_pf_code , PRELIM1.245
*CALL ARGPPX PRELIM1.246
& ErrorStatus,CMESSAGE) PRELIM1.247
IPLAST = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_pl_code , PRELIM1.248
*CALL ARGPPX PRELIM1.249
& ErrorStatus,CMESSAGE) PRELIM1.250
PTR_PROG= EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_ptr_code , PRELIM1.251
*CALL ARGPPX PRELIM1.252
& ErrorStatus,CMESSAGE) PRELIM1.253
LBVC = EXPPXI(MODL_L ,ISEC_L ,ITEM_L,ppx_lbvc_code , PRELIM1.254
*CALL ARGPPX PRELIM1.255
& ErrorStatus,CMESSAGE) PRELIM1.256
PRELIM1.257
! Check availability of diagnostic PRELIM1.258
CALL TSTMSK(MODL_L,ISEC_L,LMASK,LDUM,ErrorStatus,CMESSAGE) GSS3F401.818
IF(.NOT.LMASK) THEN PRELIM1.261
WRITE(6,*) PRELIM1.262
& 'MESSAGE FROM ROUTINE PRELIM: ', GSS3F401.819
& 'DIAGNOSTIC NOT AVAILABLE TO THIS VERSION ', GSS3F401.820
& 'REQUEST DENIED' GSS3F401.821
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.264
& MODL_L,ISEC_L,ITEM_L PRELIM1.265
GOTO 999 PRELIM1.267
END IF PRELIM1.268
PRELIM1.269
NRECS=NRECS+1 PRELIM1.270
PRELIM1.271
LIST_S(st_model_code ,NRECS)= MODL_L PRELIM1.272
LIST_S(st_sect_no_code,NRECS)= ISEC_L PRELIM1.273
LIST_S(st_item_code ,NRECS)= ITEM_L PRELIM1.274
! Prelim pointer for 'child' records PRELIM1.275
LIST_S(NELEMP+1 ,NRECS)= NRECS PRELIM1.276
LIST_S(st_lookup_ptr ,NRECS)=-1 PRELIM1.277
PRELIM1.278
IF( (ISPACE.EQ.2).OR.(ISPACE.EQ.4) GSS1F403.49
& .OR.(ISPACE.EQ.7).OR.(ISPACE.EQ.8) ) THEN GSS1F403.50
LIST_S(st_input_code,NRECS)=0 PRELIM1.280
ELSE PRELIM1.281
LIST_S(st_input_code,NRECS)=1 PRELIM1.282
END IF PRELIM1.283
PRELIM1.284
IF((ITIMA.GE.5).AND.(ITIMA.LE.12)) THEN PRELIM1.289
LMEAN=.TRUE. PRELIM1.290
ELSE PRELIM1.291
LMEAN=.FALSE. PRELIM1.292
END IF PRELIM1.293
PRELIM1.294
PRELIM1.295
! 1.1 Expand the domain profile --------------------------- PRELIM1.296
PRELIM1.297
! Averaging and Weighting PRELIM1.298
IM=IMSK_D(IDOM_L) GSS3F401.822
IF ((IGP.EQ. 2).OR.(IGP.EQ. 3) .OR. PRELIM1.302
& (IGP.EQ.12).OR.(IGP.EQ.13)) THEN PRELIM1.303
! Diags only available over land/sea PRELIM1.304
IF((IMSK_D(IDOM_L) .EQ. 1) .AND. PRELIM1.305
& (IGP.EQ.3.OR.IGP.EQ.13)) THEN PRELIM1.306
! Diag requested over land+sea, only available over sea PRELIM1.307
IM=3 PRELIM1.308
ELSE IF((IMSK_D(IDOM_L) .EQ. 1) .AND. PRELIM1.310
& (IGP.EQ.2.OR.IGP.EQ.12))THEN PRELIM1.311
! Diag requested over land+sea, only available over land PRELIM1.312
IM=2 PRELIM1.313
ELSE IF((IMSK_D(IDOM_L) .EQ. 2) .AND. PRELIM1.315
& (IGP.EQ.3.OR.IGP.EQ.13))THEN PRELIM1.316
! Diag requested over land, only available over sea PRELIM1.317
WRITE(6,*)'PRELIM: CHANGED TO SEA DIAG' PRELIM1.318
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.319
& MODL_L,ISEC_L,ITEM_L PRELIM1.320
IM=3 GSS3F401.823
ELSE IF((IMSK_D(IDOM_L) .EQ. 3) .AND. PRELIM1.324
& (IGP.EQ.2.OR.IGP.EQ.12))THEN PRELIM1.325
! Diag requested over sea, only available over land PRELIM1.326
WRITE(6,*)'PRELIM: CHANGED TO LAND DIAG' PRELIM1.327
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.328
& MODL_L,ISEC_L,ITEM_L PRELIM1.329
IM=2 PRELIM1.331
END IF GSS3F401.824
END IF PRELIM1.335
PRELIM1.336
LIST_S(st_gridpoint_code,NRECS)=IM+10*IMN_D(IDOM_L) PRELIM1.337
LIST_S(st_weight_code ,NRECS)= IWT_D(IDOM_L) PRELIM1.338
PRELIM1.339
! Horizontal area PRELIM1.340
! - convert lat/long spec to row/column numbers if appropriate; PRELIM1.341
! - convert lat/long spec to equatorial lat/long if appropriate. PRELIM1.342
IF(IOPA_D(IDOM_L).EQ.1) THEN GSS3F401.825
! Full domain GSS3F401.826
CALL LLTORC(IGP,90,-90,0,360, PRELIM1.346
& LIST_S(st_north_code,NRECS),LIST_S(st_south_code,NRECS), PRELIM1.347
& LIST_S(st_west_code,NRECS),LIST_S(st_east_code,NRECS)) PRELIM1.348
ELSE IF(IOPA_D(IDOM_L).EQ.2 ) THEN GSS3F401.827
! N Hemis GSS3F401.828
CALL LLTORC(IGP,90,0,0,360, PRELIM1.352
& LIST_S(st_north_code,NRECS),LIST_S(st_south_code,NRECS), PRELIM1.353
& LIST_S(st_west_code,NRECS),LIST_S(st_east_code,NRECS)) PRELIM1.354
ELSE IF(IOPA_D(IDOM_L).EQ.3 ) THEN GSS3F401.829
! S Hemis GSS3F401.830
CALL LLTORC(IGP,0,-90,0,360, PRELIM1.358
& LIST_S(st_north_code,NRECS),LIST_S(st_south_code,NRECS), PRELIM1.359
& LIST_S(st_west_code,NRECS),LIST_S(st_east_code,NRECS)) PRELIM1.360
ELSE IF(IOPA_D(IDOM_L).EQ.4 ) THEN GSS3F401.831
! 90N-30N GSS3F401.832
CALL LLTORC(IGP,90,30,0,360, PRELIM1.364
& LIST_S(st_north_code,NRECS),LIST_S(st_south_code,NRECS), PRELIM1.365
& LIST_S(st_west_code,NRECS),LIST_S(st_east_code,NRECS)) PRELIM1.366
ELSE IF(IOPA_D(IDOM_L).EQ.5 ) THEN GSS3F401.833
! 30S-90S GSS3F401.834
CALL LLTORC(IGP,-30,-90,0,360, PRELIM1.370
& LIST_S(st_north_code,NRECS),LIST_S(st_south_code,NRECS), PRELIM1.371
& LIST_S(st_west_code,NRECS),LIST_S(st_east_code,NRECS)) PRELIM1.372
ELSE IF(IOPA_D(IDOM_L).EQ.6 ) THEN GSS3F401.835
! 30N-00N GSS3F401.836
CALL LLTORC(IGP,30,00,0,360, PRELIM1.376
& LIST_S(st_north_code,NRECS),LIST_S(st_south_code,NRECS), PRELIM1.377
& LIST_S(st_west_code,NRECS),LIST_S(st_east_code,NRECS)) PRELIM1.378
ELSE IF(IOPA_D(IDOM_L).EQ.7 ) THEN GSS3F401.837
! 00S-30S GSS3F401.838
CALL LLTORC(IGP,00,-30,0,360, PRELIM1.382
& LIST_S(st_north_code,NRECS),LIST_S(st_south_code,NRECS), PRELIM1.383
& LIST_S(st_west_code,NRECS),LIST_S(st_east_code,NRECS)) PRELIM1.384
ELSE IF(IOPA_D(IDOM_L).EQ.8 ) THEN GSS3F401.839
! 30N-30S GSS3F401.840
CALL LLTORC(IGP,30,-30,0,360, PRELIM1.388
& LIST_S(st_north_code,NRECS),LIST_S(st_south_code,NRECS), PRELIM1.389
& LIST_S(st_west_code,NRECS),LIST_S(st_east_code,NRECS)) PRELIM1.390
ELSE IF(IOPA_D(IDOM_L).EQ.9 ) THEN GSS3F401.841
! Other lat/long spec GSS3F401.842
CALL LLTORC(IGP,INTH_D(IDOM_L),ISTH_D(IDOM_L), PRELIM1.394
& IWST_D(IDOM_L),IEST_D(IDOM_L), PRELIM1.395
& LIST_S(st_north_code,NRECS),LIST_S(st_south_code,NRECS), PRELIM1.396
& LIST_S(st_west_code,NRECS),LIST_S(st_east_code,NRECS)) PRELIM1.397
ELSE IF(IOPA_D(IDOM_L).EQ.10) THEN GSS3F401.843
! Grid point spec GSS3F401.844
CALL LLTORC(IGP,90,-90,0,360,IY1,IY2,IX1,IX2) PRELIM1.401
LIST_S(st_north_code,NRECS)=MIN(INTH_D(IDOM_L),IY2) PRELIM1.402
LIST_S(st_south_code,NRECS)=MIN(ISTH_D(IDOM_L),IY2) PRELIM1.403
LIST_S(st_west_code ,NRECS)=MIN(IWST_D(IDOM_L),IX2) PRELIM1.404
LIST_S(st_east_code ,NRECS)=MIN(IEST_D(IDOM_L),IX2) PRELIM1.405
ELSE GSS3F401.845
WRITE(6,*) 'PRELIM: INVALD DOMAIN AREA OPTION=', GSS1F400.1229
& IOPA_D(IDOM_L) GSS1F400.1230
WRITE(6,*) 'MODEL,SECTION,ITEM ', GSS1F400.1231
& MODL_L,ISEC_L,ITEM_L GSS1F400.1232
NRECS=NRECS-1 PRELIM1.412
GOTO 999 PRELIM1.413
END IF PRELIM1.415
PRELIM1.416
! Input level setting PRELIM1.417
MODEL_LEV=DISCT_LEV(ILEV,ErrorStatus,CMESSAGE) GSS3F401.846
IF (MODEL_LEV) THEN GSS3F401.847
! Model levels GSS3F401.848
! Set bottom level GSS3F401.849
CALL LEVCOD(IBOT,IBOT1,ErrorStatus,CMESSAGE) GSS3F401.850
! Set top level GSS3F401.851
CALL LEVCOD(ITOP,ITOP1,ErrorStatus,CMESSAGE) GSS3F401.852
! Contig. range of model levels GSS3F401.853
IF(IFLAG.EQ.0) THEN GSS3F401.854
LIST_S(st_input_bottom,NRECS)=IBOT1 PRELIM1.426
LIST_S(st_input_top ,NRECS)=ITOP1 PRELIM1.427
! Non-contig. levels list GSS3F401.855
ELSE IF(IFLAG.EQ.1) THEN GSS3F401.856
LIST_S(st_input_bottom,NRECS)=-1 PRELIM1.429
LIST_S(st_input_top ,NRECS)= 1 PRELIM1.430
END IF PRELIM1.431
ELSE GSS3F401.857
! Non-model levels GSS3F401.858
IF(ILEV.EQ.3) THEN GSS3F401.859
! Pressure levels GSS3F401.860
LIST_S(st_input_bottom,NRECS)=-1 GSS3F401.861
LIST_S(st_input_top ,NRECS)= 2 GSS3F401.862
ELSE IF(ILEV.EQ.4) THEN GSS3F401.863
! Height levels GSS3F401.864
LIST_S(st_input_bottom,NRECS)=-1 GSS3F401.865
LIST_S(st_input_top ,NRECS)= 3 GSS3F401.866
ELSE IF(ILEV.EQ.5) THEN GSS3F401.867
! Special levels GSS3F401.868
LIST_S(st_input_bottom,NRECS)=100 GSS3F401.869
LIST_S(st_input_top ,NRECS)=LBVC GSS3F401.870
ELSE IF(ILEV.EQ.7) THEN GSS3F401.871
! Theta levels GSS3F401.872
LIST_S(st_input_bottom,NRECS)=-1 GSS3F401.873
LIST_S(st_input_top ,NRECS)= 4 GSS3F401.874
ELSE IF(ILEV.EQ.8) THEN GSS3F401.875
! PV levels GSS3F401.876
LIST_S(st_input_bottom,NRECS)=-1 GSS3F401.877
LIST_S(st_input_top ,NRECS)= 5 GSS3F401.878
ELSE IF(ILEV.EQ.9) THEN GSS3F401.879
! Cloud threshold levels GSS3F401.880
LIST_S(st_input_bottom,NRECS)=-1 GSS3F401.881
LIST_S(st_input_top ,NRECS)= 6 GSS3F401.882
END IF GSS3F401.883
END IF PRELIM1.463
PRELIM1.464
! Output level specification PRELIM1.466
MODEL_LEV=DISCT_LEV(ILEV,ErrorStatus,CMESSAGE) GSS3F401.884
IF (MODEL_LEV) THEN GSS3F401.885
! Model levels GSS3F401.886
IF (LEVB_D(IDOM_L).GE.0) THEN PRELIM1.470
! Contiguous range of model levels GSS3F401.887
LIST_S(st_output_bottom,NRECS)=MAX(LEVB_D(IDOM_L),IBOT1) PRELIM1.473
LIST_S(st_output_top ,NRECS)=MIN(LEVT_D(IDOM_L),ITOP1) PRELIM1.474
IF ((LEVB_D(IDOM_L).LT.IBOT1).OR. PRELIM1.476
& (LEVT_D(IDOM_L).GT.ITOP1)) THEN PRELIM1.477
WRITE(6,*) GSS3F401.888
& 'MESSAGE FROM ROUITNE PRELIM: DIAGNOSTIC REQUEST ', GSS3F401.889
& 'HAS LEVEL RANGE OUT OF BOUNDS; HAS BEEN CORRECTED' GSS3F401.890
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.479
& MODL_L,ISEC_L,ITEM_L PRELIM1.480
END IF GSS3F401.891
IF ( ( TS_D(IDOM_L).EQ. 'Y').AND. GSS1F400.1233
& ((LEVB_D(IDOM_L).LT.IBOT1).OR. GSS1F400.1234
& (LEVT_D(IDOM_L).GT.ITOP1)) ) THEN GSS1F400.1235
WRITE(6,*) GSS1F400.1236
& 'MESSAGE FROM ROUTINE PRELIM: TIME SERIES DOMAIN ', GSS3F401.892
& 'HAS INCONSISTENT LEVELS; DIAGNOSTIC REQUEST IGNORED' GSS3F401.893
WRITE(6,*) 'MODEL,SECTION,ITEM ', GSS1F400.1238
& MODL_L,ISEC_L,ITEM_L GSS1F400.1239
NRECS=NRECS-1 GSS1F400.1240
GOTO 999 GSS1F400.1241
END IF GSS1F400.1242
IF ((LEVT_D(IDOM_L).LT.IBOT1).OR. PRELIM1.494
& (LEVB_D(IDOM_L).GT.ITOP1)) THEN PRELIM1.495
WRITE(6,*) PRELIM1.496
& 'MESSAGE FROM ROUTINE PRELIM: DIAGNOSTIC REQUEST ', GSS3F401.894
& 'HAS TOP/BOTTOM LEVELS INCONSISTENT; REQUEST IGNORED' GSS3F401.895
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.498
& MODL_L,ISEC_L,ITEM_L PRELIM1.499
NRECS=NRECS-1 PRELIM1.501
GOTO 999 PRELIM1.502
END IF PRELIM1.503
ELSE GSS3F401.896
! Non-contig. list of model levels GSS3F401.897
LIST_S(st_output_bottom,NRECS)=-(IDOM_L+LEV_OFFSET) PRELIM1.507
LIST_S(st_output_top ,NRECS)=1 PRELIM1.508
END IF PRELIM1.510
ELSE GSS3F401.898
! Non-model levels GSS3F401.899
IF(ILEV.EQ.5) THEN GSS3F401.900
! Special level GSS3F401.901
LIST_S(st_output_bottom,NRECS)=100 GSS3F401.902
LIST_S(st_output_top ,NRECS)=LBVC GSS3F401.903
ELSE IF(ILEV.EQ.3) THEN GSS3F401.904
! Pressure levels GSS3F401.905
LIST_S(st_output_bottom,NRECS)=-(IDOM_L+LEV_OFFSET) GSS3F401.906
LIST_S(st_output_top ,NRECS)=2 GSS3F401.907
ELSE IF(ILEV.EQ.4) THEN GSS3F401.908
! Height levels GSS3F401.909
LIST_S(st_output_bottom,NRECS)=-(IDOM_L+LEV_OFFSET) GSS3F401.910
LIST_S(st_output_top ,NRECS)=3 GSS3F401.911
ELSE IF(ILEV.EQ.7 ) THEN GSS3F401.912
! Theta levels GSS3F401.913
LIST_S(st_output_bottom,NRECS)=-(IDOM_L+LEV_OFFSET) GSS3F401.914
LIST_S(st_output_top ,NRECS)=4 GSS3F401.915
ELSE IF(ILEV.EQ.8 ) THEN GSS3F401.916
! PV levels GSS3F401.917
LIST_S(st_output_bottom,NRECS)=-(IDOM_L+LEV_OFFSET) GSS3F401.918
LIST_S(st_output_top ,NRECS)=5 GSS3F401.919
ELSE IF(ILEV.EQ.9 ) THEN GSS3F401.920
! Cloud threshold levels GSS3F401.921
LIST_S(st_output_bottom,NRECS)=-(IDOM_L+LEV_OFFSET) GSS3F401.922
LIST_S(st_output_top ,NRECS)=6 GSS3F401.923
ELSE GSS3F401.924
WRITE(6,*) 'PRELIM: DOMAIN LEVEL OPTION=',IOPL_D(IDOM_L) GSS3F401.925
WRITE(6,*) 'MODEL,SECTION,ITEM ', GSS3F401.926
& MODL_L,ISEC_L,ITEM_L PRELIM1.546
NRECS=NRECS-1 GSS3F401.927
GOTO 999 GSS3F401.928
END IF GSS3F401.929
END IF PRELIM1.551
PRELIM1.552
! Output pseudo-levels level setting PRELIM1.553
IF(IPSEUDO.NE.PLT_D(IDOM_L)) THEN PRELIM1.555
WRITE(6,*) PRELIM1.556
& 'MESSAGE FROM ROUTINE PRELIM: DIAGNOSTIC REQUEST HAS ', GSS3F401.930
& 'INVALID PSEUDO LEVEL TYPE; REQUEST IGNORED' GSS3F401.931
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.558
& MODL_L,ISEC_L,ITEM_L PRELIM1.559
NRECS=NRECS-1 PRELIM1.560
GOTO 999 PRELIM1.562
END IF PRELIM1.563
LIST_S(st_pseudo_in,NRECS)=0 !(This is set in INPUTL) GSS3F401.932
IF(IPSEUDO.GT.0) THEN GSS3F401.933
! Pseudo levels list for this diagnostic GSS3F401.934
LIST_S(st_pseudo_out,NRECS)=PLPOS_D(IDOM_L) PRELIM1.569
LENPLST(PLPOS_D(IDOM_L)) =PLLEN_D(IDOM_L) GSS3F401.935
IFIRST=PSLIST_D(1,PLPOS_D(IDOM_L)) PRELIM1.571
ILAST =PSLIST_D(PLLEN_D(IDOM_L),PLPOS_D(IDOM_L)) PRELIM1.572
! Check pseudo level limits GSS3F401.936
CALL PSLIMS(IPFIRST,IPLAST,IFIRST1,ILAST1) PRELIM1.573
IF(IFIRST.LT.IFIRST1) THEN PRELIM1.575
WRITE(6,*) PRELIM1.576
& 'MESSAGE FROM ROUTINE PRELIM: DIAGNOSTIC REQUEST HAS ', GSS3F401.937
& 'FIRST PSEUDO LEVEL TOO LOW; REQUEST IGNORED' GSS3F401.938
WRITE(6,*) 'MODEL,SECTION,ITEM ', GSS3F401.939
& MODL_L,ISEC_L,ITEM_L GSS3F401.940
NRECS=NRECS-1 GSS3F401.941
GOTO 999 GSS3F401.942
END IF GSS3F401.943
IF(ILAST.GT.ILAST1) THEN GSS3F401.944
WRITE(6,*) GSS3F401.945
& 'MESSAGE FROM ROUTINE PRELIM: DIAGNOSTIC REQUEST HAS ', GSS3F401.946
& 'LAST PSEUDO LEVEL TOO HIGH; REQUEST IGNORED' GSS3F401.947
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.578
& MODL_L,ISEC_L,ITEM_L PRELIM1.579
NRECS=NRECS-1 PRELIM1.580
GOTO 999 PRELIM1.582
END IF PRELIM1.583
ELSE PRELIM1.595
LIST_S(st_pseudo_out,NRECS)=0 GSS3F401.948
END IF PRELIM1.599
PRELIM1.600
! Time-series domain profiles PRELIM1.601
IF(TS_D(IDOM_L).EQ.'Y') THEN GSS1F400.1244
! Pointer for location of time series GSS1F400.1245
LIST_S(st_series_ptr,NRECS)=NPOS_TS(IDOM_L) GSS1F400.1246
ELSE GSS1F400.1247
LIST_S(st_series_ptr,NRECS)=0 GSS1F400.1248
END IF GSS1F400.1249
PRELIM1.617
! 1.2 Expand the useage profile -------------------------- PRELIM1.618
PRELIM1.619
IF (LOCN_U(IUSE_L).EQ.5) THEN ! PP file PRELIM1.620
PRELIM1.621
IF(LMEAN) THEN PRELIM1.622
LIST_S(st_output_code,NRECS)=-27 PRELIM1.623
LIST_S(st_macrotag,NRECS)=0 PRELIM1.624
ELSE PRELIM1.625
WRITE(6,*) GSS3F401.949
& 'MESSAGE FROM ROUTINE PRELIM: DIAGNOSTIC REQUEST HAS ', GSS3F401.950
& 'OUTPUT DESTINATION CODE 5 (CLIMATE MEAN PP FILE) ', GSS3F401.951
& 'BUT DIAGNOSTIC IS NOT A CLIMATE MEAN; REQUEST IGNORED' GSS3F401.952
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.627
& MODL_L,ISEC_L,ITEM_L PRELIM1.628
NRECS=NRECS-1 PRELIM1.630
GOTO 999 PRELIM1.631
END IF PRELIM1.632
PRELIM1.633
ELSE IF (LMEAN) THEN PRELIM1.634
PRELIM1.635
WRITE(6,*) GSS3F401.953
& 'MESSAGE FROM ROUTINE PRELIM: DIAGNOSTIC REQUEST IS A ', GSS3F401.954
& 'CLIMATE MEAN - SHOULD HAVE OUTPUT DESTINATION CODE 5 ', GSS3F401.955
& '(CLIMATE MEAN PP FILE); REQUEST IGNORED' GSS3F401.956
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.637
& MODL_L,ISEC_L,ITEM_L PRELIM1.638
NRECS=NRECS-1 PRELIM1.640
GOTO 999 PRELIM1.641
PRELIM1.642
ELSE IF (LOCN_U(IUSE_L).EQ.3) THEN ! PP file PRELIM1.643
PRELIM1.644
LIST_S(st_output_code,NRECS)=-IUNT_U(IUSE_L) PRELIM1.645
LIST_S(st_macrotag,NRECS)=0 PRELIM1.646
PRELIM1.647
ELSE IF (LOCN_U(IUSE_L).EQ.1) THEN ! Dump store: set user tag PRELIM1.648
PRELIM1.649
LIST_S(st_output_code,NRECS)=1 PRELIM1.650
LIST_S(st_macrotag,NRECS)=IUNT_U(IUSE_L) PRELIM1.651
PRELIM1.652
ELSE IF (LOCN_U(IUSE_L).EQ.6) THEN ! Secondary dump store: PRELIM1.653
! set user tag PRELIM1.654
LIST_S(st_output_code,NRECS)=2 PRELIM1.655
LIST_S(st_macrotag,NRECS)=IUNT_U(IUSE_L) PRELIM1.656
PRELIM1.657
ELSE IF (LOCN_U(IUSE_L).EQ.2) THEN ! Climate mean: tag set PRELIM1.658
! 1000*(time mean tag) PRELIM1.659
LIST_S(st_output_code,NRECS)=1 PRELIM1.660
LIST_S(st_macrotag,NRECS)=IUNT_U(IUSE_L)*1000 PRELIM1.661
PRELIM1.662
ELSE IF (LOCN_U(IUSE_L).EQ.4)THEN ! Printed output PRELIM1.663
PRELIM1.664
LIST_S(st_output_code,NRECS)=7 PRELIM1.665
LIST_S(st_macrotag,NRECS)=0 PRELIM1.666
PRELIM1.667
ELSE PRELIM1.668
PRELIM1.669
WRITE(6,*) 'PRELIM: IVALID USEAGE OPTION=', GSS1F400.1250
& LOCN_U(IUSE_L) GSS1F400.1251
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.671
& MODL_L,ISEC_L,ITEM_L PRELIM1.672
NRECS=NRECS-1 PRELIM1.674
GOTO 999 PRELIM1.675
PRELIM1.676
END IF PRELIM1.677
PRELIM1.678
! 1.3 Expand the time profile ------------------------------ PRELIM1.679
PRELIM1.680
! Initialise as single time field PRELIM1.681
PRELIM1.682
! Set time processing record PRELIM1.683
PRELIM1.684
IF (LMEAN) THEN PRELIM1.685
IF (ITYP_T(ITIM_L).NE.1) THEN PRELIM1.686
WRITE(6,*) PRELIM1.687
& 'PRELIM: CLIMATE MEANS MUST NOT BE TIME PROCESSED' PRELIM1.688
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.689
& MODL_L,ISEC_L,ITEM_L PRELIM1.690
END IF PRELIM1.692
LIST_S(st_proc_no_code,NRECS)=1 PRELIM1.693
ELSE PRELIM1.694
LIST_S(st_proc_no_code,NRECS)=ITYP_T(ITIM_L) PRELIM1.695
END IF PRELIM1.696
PRELIM1.697
! Initialise offset to 0 GSM5F404.7
LIST_S(st_offset_code,NRECS)=0 GSM5F404.8
! Set period record PRELIM1.698
PRELIM1.699
IF (ITYP_T(ITIM_L).EQ.1.OR.LMEAN) THEN ! No period PRELIM1.700
LIST_S(st_period_code,NRECS)=0 PRELIM1.701
ELSE IF((INTV_T(ITIM_L).EQ.-1).AND. PRELIM1.702
& (ITYP_T(ITIM_L).EQ.2)) THEN PRELIM1.703
LIST_S(st_period_code,NRECS)=-1 PRELIM1.704
ELSE PRELIM1.705
LIST_S(st_period_code,NRECS)= PRELIM1.706
& TOTIMP(INTV_T(ITIM_L),UNT1_T(ITIM_L),MODL_L) GSS3F401.957
if (LIST_S(st_freq_code,NRECS) .eq. -999) then GDW1F404.195
ErrorStatus = 101 GDW1F404.196
cmessage = 'TOTIMP:UNEXPECTED TIME UNIT or '// GDW1F404.197
& 'IRREGULAR DUMPS FOR DUMP FREQUENCY' GDW1F404.198
GOTO 9999 GDW1F404.199
endif GDW1F404.200
END IF PRELIM1.708
PRELIM1.709
IF (LMEAN.AND.(IOPT_T(ITIM_L).NE.1)) THEN PRELIM1.710
WRITE(6,*) PRELIM1.711
& 'PRELIM: CLIMATE MEANS MUST USE STANDARD FREQUENCY' PRELIM1.712
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.713
& MODL_L,ISEC_L,ITEM_L PRELIM1.714
NRECS=NRECS-1 PRELIM1.715
GOTO 999 PRELIM1.717
END IF PRELIM1.718
PRELIM1.719
IF(IOPT_T(ITIM_L).EQ.1) THEN PRELIM1.720
!Regular output times PRELIM1.721
LIST_S(st_freq_code,NRECS)= PRELIM1.722
& TOTIMP(IFRE_T(ITIM_L),UNT3_T(ITIM_L),MODL_L) GSS3F401.958
if (LIST_S(st_freq_code,NRECS) .eq. -999) then GDW1F404.201
ErrorStatus = 102 GDW1F404.202
cmessage = 'TOTIMP:UNEXPECTED TIME UNIT or '// GDW1F404.203
& 'IRREGULAR DUMPS FOR DUMP FREQUENCY' GDW1F404.204
GOTO 9999 GDW1F404.205
endif GDW1F404.206
LIST_S(st_start_time_code,NRECS)= PRELIM1.724
& TOTIMP(ISTR_T(ITIM_L),UNT3_T(ITIM_L),MODL_L) GSS3F401.959
if (LIST_S(st_start_time_code,NRECS) .eq. -999) then GDW1F404.207
ErrorStatus = 103 GDW1F404.208
cmessage = 'TOTIMP:UNEXPECTED TIME UNIT or '// GDW1F404.209
& 'IRREGULAR DUMPS FOR DUMP FREQUENCY' GDW1F404.210
GOTO 9999 GDW1F404.211
endif GDW1F404.212
LIST_S(st_end_time_code,NRECS)= PRELIM1.726
& TOTIMP(IEND_T(ITIM_L),UNT3_T(ITIM_L),MODL_L) GSS3F401.960
if (LIST_S(st_end_time_code,NRECS) .eq. -999) then GDW1F404.213
ErrorStatus = 104 GDW1F404.214
cmessage = 'TOTIMP:UNEXPECTED TIME UNIT or '// GDW1F404.215
& 'IRREGULAR DUMPS FOR DUMP FREQUENCY' GDW1F404.216
GOTO 9999 GDW1F404.217
endif GDW1F404.218
PRELIM1.728
! Set end time to -1 if output requested to end of run PRELIM1.729
IF(IEND_T(ITIM_L).EQ.-1) LIST_S(st_end_time_code,NRECS)=-1 PRELIM1.730
PRELIM1.731
! Correct start time for radiation, periodic convection, leaf ABX1F405.3
! phenology and vegetation competition ABX1F405.4
IF((ITIMA.EQ.2).AND.(A_LW_RADSTEP.NE.1)) THEN PRELIM1.733
IMD=MOD(LIST_S(st_start_time_code,NRECS),A_LW_RADSTEP) PRELIM1.734
LIST_S(st_start_time_code,NRECS)= PRELIM1.735
& LIST_S(st_start_time_code,NRECS)+1-IMD PRELIM1.736
LOFFSET=.TRUE. PRELIM1.737
ELSE IF((ITIMA.EQ.3).AND.(A_SW_RADSTEP.NE.1)) THEN PRELIM1.738
IMD=MOD(LIST_S(st_start_time_code,NRECS),A_SW_RADSTEP) PRELIM1.739
LIST_S(st_start_time_code,NRECS)= PRELIM1.740
& LIST_S(st_start_time_code,NRECS)+1-IMD PRELIM1.741
LOFFSET=.TRUE. PRELIM1.742
ELSE IF((ITIMA.EQ.13).AND.(A_CONV_STEP.NE.1)) THEN PRELIM1.743
IMD=MOD(LIST_S(st_start_time_code,NRECS),A_CONV_STEP) PRELIM1.744
LIST_S(st_start_time_code,NRECS)= PRELIM1.745
& LIST_S(st_start_time_code,NRECS)+1-IMD PRELIM1.746
LOFFSET=.TRUE. PRELIM1.747
ELSE IF((ITIMA.EQ.14).AND.(PHENOL_PERIOD.NE.1)) THEN ABX1F405.5
IMD=MOD(LIST_S(st_start_time_code,NRECS),PHENOL_PERIOD) ABX1F405.6
LIST_S(st_start_time_code,NRECS)= ABX1F405.7
& LIST_S(st_start_time_code,NRECS)+1-IMD ABX1F405.8
LOFFSET=.TRUE. ABX1F405.9
ELSE IF((ITIMA.EQ.15).AND.(TRIFFID_PERIOD.NE.1)) THEN ABX1F405.10
IMD=MOD(LIST_S(st_start_time_code,NRECS),TRIFFID_PERIOD) ABX1F405.11
LIST_S(st_start_time_code,NRECS)= ABX1F405.12
& LIST_S(st_start_time_code,NRECS)+1-IMD ABX1F405.13
LOFFSET=.TRUE. ABX1F405.14
ELSE PRELIM1.748
LOFFSET=.FALSE. PRELIM1.749
END IF PRELIM1.750
ELSE IF(IOPT_T(ITIM_L).EQ.2) THEN PRELIM1.752
!List of specified output times PRELIM1.754
LIST_S(st_freq_code,NRECS)=-ITIM_L PRELIM1.756
ELSE GSS3F401.961
WRITE(6,*)'PRELIM: INVALID OUTPUT TIMES CODE' GSS1F400.1254
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.764
& MODL_L,ISEC_L,ITEM_L PRELIM1.765
NRECS=NRECS-1 PRELIM1.767
GOTO 999 PRELIM1.768
END IF PRELIM1.770
PRELIM1.771
IF (LMEAN) LIST_S(st_freq_code,NRECS)=1 PRELIM1.772
PRELIM1.773
IF ((LIST_S(st_proc_no_code,NRECS).GT.1).AND. PRELIM1.774
& (LIST_S(st_proc_no_code,NRECS).LE.6)) THEN PRELIM1.775
! Other than single time field PRELIM1.776
IF(NRECS.GE.NRECDP) THEN PRELIM1.777
WRITE(6,*) PRELIM1.778
& 'PRELIM: TOO MANY S_LIST REQUESTS. REQUEST IGNORED' PRELIM1.779
WRITE(6,*) 'MODEL,SECTION,ITEM ', GSS1F400.1255
& MODL_L,ISEC_L,ITEM_L GSS1F400.1256
NRECS=NRECS-1 PRELIM1.781
GOTO 999 PRELIM1.782
END IF PRELIM1.783
PRELIM1.784
DO I=1,NELEMP+1 ! Copy stash list forward PRELIM1.785
LIST_S(I,NRECS+1)=LIST_S(I,NRECS) PRELIM1.786
END DO PRELIM1.787
PRELIM1.788
IF(LOFFSET) THEN ! Rad or conv timesteps, PRELIM1.789
! 1 alresdy added PRELIM1.790
LIST_S(st_start_time_code,NRECS+1)= PRELIM1.791
& LIST_S(st_start_time_code,NRECS+1)-1 PRELIM1.792
IF (LIST_S(st_period_code,NRECS).NE.-1) THEN PRELIM1.793
LIST_S(st_start_time_code,NRECS)= PRELIM1.794
& LIST_S(st_start_time_code,NRECS)- PRELIM1.795
& LIST_S(st_period_code,NRECS) PRELIM1.796
ELSE PRELIM1.797
LIST_S(st_start_time_code,NRECS)=1 PRELIM1.798
END IF PRELIM1.799
PRELIM1.800
ELSE PRELIM1.801
PRELIM1.802
IF (LIST_S(st_period_code,NRECS).NE.-1) THEN PRELIM1.803
! Offsets are added to start time GSM5F404.9
LIST_S(st_offset_code,NRECS)= GSM5F404.10
& TOTIMP(IOFF_T(ITIM_L),UNT2_T(ITIM_L),MODL_L) GSM5F404.11
if (LIST_S(st_offset_code,NRECS) .eq. -999) then GSM5F404.12
ErrorStatus = 1 GSM5F404.13
cmessage = 'TOTIMP:UNEXPECTED TIME UNIT' GSM5F404.14
GOTO 9999 GSM5F404.15
endif GSM5F404.16
LIST_S(st_start_time_code,NRECS)= PRELIM1.804
& LIST_S(st_start_time_code,NRECS)- PRELIM1.805
& LIST_S(st_period_code,NRECS)+1+ GSM5F404.17
& LIST_S(st_offset_code,NRECS) GSM5F404.18
ELSE PRELIM1.807
LIST_S(st_start_time_code,NRECS)=1 PRELIM1.808
END IF PRELIM1.809
PRELIM1.810
END IF PRELIM1.811
PRELIM1.812
IF(LIST_S(st_start_time_code,NRECS).LT.1) THEN PRELIM1.813
WRITE(6,*) PRELIM1.814
& 'PRELIM: START TIME BEFORE PERIOD, SETTING TO 1' PRELIM1.815
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.816
& MODL_L,ISEC_L,ITEM_L PRELIM1.817
LIST_S(st_start_time_code,NRECS)=1 PRELIM1.819
END IF PRELIM1.820
PRELIM1.821
LIST_S(st_proc_no_code ,NRECS+1)=1 PRELIM1.822
PRELIM1.823
LIST_S(st_input_bottom ,NRECS+1)= PRELIM1.824
& LIST_S(st_output_bottom,NRECS ) PRELIM1.825
PRELIM1.826
LIST_S(st_input_top ,NRECS+1)= PRELIM1.827
& LIST_S(st_output_top ,NRECS ) PRELIM1.828
PRELIM1.829
LIST_S(st_input_code ,NRECS+1)=-NRECS PRELIM1.830
LIST_S(st_output_code ,NRECS )=1 PRELIM1.831
LIST_S(st_series_ptr ,NRECS+1)=0 PRELIM1.832
LIST_S(NELEMP+1 ,NRECS+1)=NRECS+1 PRELIM1.833
PRELIM1.834
LIST_S(st_freq_code,NRECS)= ! Frequency PRELIM1.835
& TOTIMP(ISAM_T(ITIM_L),UNT2_T(ITIM_L),MODL_L) GSS3F401.962
if (LIST_S(st_freq_code,NRECS) .eq. -999) then GDW1F404.219
ErrorStatus = 105 GDW1F404.220
cmessage = 'TOTIMP:UNEXPECTED TIME UNIT or '// GDW1F404.221
& 'IRREGULAR DUMPS FOR DUMP FREQUENCY' GDW1F404.222
GOTO 9999 GDW1F404.223
endif GDW1F404.224
PRELIM1.837
! Correct frequency for radiation, periodic convection, leaf ABX1F405.15
! phenology and vegetation competition ABX1F405.16
PRELIM1.839
IF (ITIMA.EQ.2) THEN PRELIM1.840
IF (LIST_S(st_freq_code,NRECS).EQ.1) THEN PRELIM1.841
LIST_S(st_freq_code,NRECS)=A_LW_RADSTEP PRELIM1.842
ELSE IF PRELIM1.843
& (MOD(LIST_S(st_freq_code,NRECS),A_LW_RADSTEP).NE.0) THEN PRELIM1.844
WRITE(6,*) PRELIM1.845
& 'PRELIM: INCORRECT SAMPLING FOR LW_RADSTEP. FREQ=', PRELIM1.846
& LIST_S(st_freq_code,NRECS) PRELIM1.847
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.848
& MODL_L,ISEC_L,ITEM_L PRELIM1.849
NRECS=NRECS-1 PRELIM1.851
GOTO 999 PRELIM1.852
END IF PRELIM1.853
ELSE IF(ITIMA.EQ.3) THEN PRELIM1.854
IF (LIST_S(st_freq_code,NRECS).EQ.1) THEN PRELIM1.855
LIST_S(st_freq_code,NRECS)=A_SW_RADSTEP PRELIM1.856
ELSE IF PRELIM1.857
& (MOD(LIST_S(st_freq_code,NRECS),A_SW_RADSTEP).NE.0) THEN PRELIM1.858
WRITE(6,*) PRELIM1.859
& 'PRELIM: INCORRECT SAMPLING FOR SW_RADSTEP. FREQ=', PRELIM1.860
& LIST_S(st_freq_code,NRECS) PRELIM1.861
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.862
& MODL_L,ISEC_L,ITEM_L PRELIM1.863
NRECS=NRECS-1 PRELIM1.865
GOTO 999 PRELIM1.866
END IF PRELIM1.867
ELSE IF(ITIMA.EQ.13) THEN PRELIM1.868
IF (LIST_S(st_freq_code,NRECS).EQ.1) THEN PRELIM1.869
LIST_S(st_freq_code,NRECS)=A_CONV_STEP PRELIM1.870
ELSE IF PRELIM1.871
& (MOD(LIST_S(st_freq_code,NRECS),A_CONV_STEP).NE.0) THEN PRELIM1.872
WRITE(6,*) PRELIM1.873
& 'PRELIM: INCORRECT SAMPLING FOR CONV_STEP . FREQ=', PRELIM1.874
& LIST_S(st_freq_code,NRECS) PRELIM1.875
WRITE(6,*) 'MODEL,SECTION,ITEM ', PRELIM1.876
& MODL_L,ISEC_L,ITEM_L PRELIM1.877
NRECS=NRECS-1 PRELIM1.879
GOTO 999 PRELIM1.880
END IF PRELIM1.881
ELSE IF(ITIMA.EQ.14) THEN ABX1F405.17
IF (LIST_S(st_freq_code,NRECS).EQ.1) THEN ABX1F405.18
LIST_S(st_freq_code,NRECS)=PHENOL_PERIOD ABX1F405.19
ELSE IF ABX1F405.20
& (MOD(LIST_S(st_freq_code,NRECS),PHENOL_PERIOD).NE.0) THEN ABX1F405.21
WRITE(6,*) ABX1F405.22
& 'PRELIM: INCORRECT SAMPLING FOR PHENOL_PERIOD . FREQ=', ABX1F405.23
& LIST_S(st_freq_code,NRECS) ABX1F405.24
WRITE(6,*) 'MODEL,SECTION,ITEM ', ABX1F405.25
& MODL_L,ISEC_L,ITEM_L ABX1F405.26
NRECS=NRECS-1 ABX1F405.27
GOTO 999 ABX1F405.28
END IF ABX1F405.29
ELSE IF(ITIMA.EQ.15) THEN ABX1F405.30
IF (LIST_S(st_freq_code,NRECS).EQ.1) THEN ABX1F405.31
LIST_S(st_freq_code,NRECS)=TRIFFID_PERIOD ABX1F405.32
ELSE IF ABX1F405.33
& (MOD(LIST_S(st_freq_code,NRECS),TRIFFID_PERIOD).NE.0) THEN ABX1F405.34
WRITE(6,*) ABX1F405.35
& 'PRELIM: INCORRECT SAMPLING FOR TRIFFID_PERIOD . FREQ=', ABX1F405.36
& LIST_S(st_freq_code,NRECS) ABX1F405.37
WRITE(6,*) 'MODEL,SECTION,ITEM ', ABX1F405.38
& MODL_L,ISEC_L,ITEM_L ABX1F405.39
NRECS=NRECS-1 ABX1F405.40
GOTO 999 ABX1F405.41
END IF ABX1F405.42
END IF PRELIM1.882
PRELIM1.883
! Period PRELIM1.884
PRELIM1.885
IF ((INTV_T(ITIM_L).EQ.-1).AND.(ITYP_T(ITIM_L).EQ.2)) THEN PRELIM1.886
LIST_S(st_period_code,NRECS)=-1 PRELIM1.887
ELSE PRELIM1.888
LIST_S(st_period_code,NRECS)= PRELIM1.889
& TOTIMP(INTV_T(ITIM_L),UNT1_T(ITIM_L),MODL_L) GSS3F401.963
if (LIST_S(st_period_code,NRECS) .eq. -999) then GDW1F404.225
ErrorStatus = 106 GDW1F404.226
cmessage = 'TOTIMP:UNEXPECTED TIME UNIT or '// GDW1F404.227
& 'IRREGULAR DUMPS FOR DUMP FREQUENCY' GDW1F404.228
GOTO 9999 GDW1F404.229
endif GDW1F404.230
END IF PRELIM1.891
PRELIM1.892
! Add the record - unless the output destination is the dump, PRELIM1.893
! and output at the accumulating period PRELIM1.894
IF ( LOCN_U(IUSE_L).GT.2 GSS3F401.964
& .OR. GSS3F401.965
& ( (LIST_S(st_freq_code ,NRECS+1).NE. GSS3F401.966
& LIST_S(st_period_code,NRECS )) GSS3F401.967
& .AND. GSS3F401.968
& (LIST_S(st_start_time_code,NRECS+1).NE. GSS3F401.969
& LIST_S(st_end_time_code ,NRECS+1)) ) GSS3F401.970
& )THEN GSS3F401.971
! No tag for parent GSS3F401.972
LIST_S(st_macrotag,NRECS)=0 PRELIM1.899
NRECS=NRECS+1 PRELIM1.900
END IF PRELIM1.901
GRS1F404.2
ELSE IF (LIST_S(st_proc_no_code,NRECS).EQ.8) THEN GRS1F404.3
! Option of "daily" mean timeseries GRS1F404.4
GRS1F404.5
IF(NRECS.GE.NRECDP) THEN GRS1F404.6
WRITE(6,*) GRS1F404.7
& 'PRELIM: TOO MANY S_LIST REQUESTS. REQUEST IGNORED' GRS1F404.8
WRITE(6,*) 'MODEL,SECTION,ITEM ', GRS1F404.9
& MODL_L,ISEC_L,ITEM_L GRS1F404.10
NRECS=NRECS-1 GRS1F404.11
GOTO 999 GRS1F404.12
END IF GRS1F404.13
GRS1F404.14
! Special case where 2 extra records required GRS1F404.15
! Record 1 - time mean only no spatial processing GRS1F404.16
! Record 2 - timeseries formed extracting from record 1 GRS1F404.17
! Record 3 - extract timeseries from dump ie record 2 GRS1F404.18
GRS1F404.19
DO I=1,NELEMP+1 ! Copy stash list forward GRS1F404.20
LIST_S(I,NRECS+1)=LIST_S(I,NRECS) GRS1F404.21
LIST_S(I,NRECS+2)=LIST_S(I,NRECS) GRS1F404.22
END DO GRS1F404.23
GRS1F404.24
IF(LOFFSET) THEN ! Rad or conv timesteps, GRS1F404.25
! 1 already added GRS1F404.26
LIST_S(st_start_time_code,NRECS+2)= GRS1F404.27
& LIST_S(st_start_time_code,NRECS+2)-1 GRS1F404.28
IF (LIST_S(st_period_code,NRECS).NE.-1) THEN GRS1F404.29
LIST_S(st_start_time_code,NRECS)= GRS1F404.30
& LIST_S(st_start_time_code,NRECS)- GRS1F404.31
& LIST_S(st_period_code,NRECS) GRS1F404.32
ELSE GRS1F404.33
LIST_S(st_start_time_code,NRECS)=1 GRS1F404.34
END IF GRS1F404.35
GRS1F404.36
ELSE GRS1F404.37
GRS1F404.38
IF (LIST_S(st_period_code,NRECS).NE.-1) THEN GRS1F404.39
LIST_S(st_start_time_code,NRECS)= GRS1F404.40
& LIST_S(st_start_time_code,NRECS)- GRS1F404.41
& LIST_S(st_period_code,NRECS)+1 GRS1F404.42
ELSE GRS1F404.43
LIST_S(st_start_time_code,NRECS)=1 GRS1F404.44
END IF GRS1F404.45
GRS1F404.46
END IF GRS1F404.47
GRS1F404.48
IF(LIST_S(st_start_time_code,NRECS).LT.1) THEN GRS1F404.49
WRITE(6,*) 'PRELIM: START TIME BEFORE PERIOD, SETTING TO 1' GRS1F404.50
WRITE(6,*) 'MODEL,SECTION,ITEM ',MODL_L,ISEC_L,ITEM_L GRS1F404.51
LIST_S(st_start_time_code,NRECS)=1 GRS1F404.52
END IF GRS1F404.53
GRS1F404.54
LIST_S(st_proc_no_code ,NRECS)=3 ! time mean GRS1F404.55
LIST_S(st_proc_no_code ,NRECS+1)=8 ! timseries special case GRS1F404.56
LIST_S(st_proc_no_code ,NRECS+2)=1 ! extract GRS1F404.57
GRS1F404.58
! Reset first record to no area weight or spatial processing GRS1F404.59
! ie first record just controls time meaning GRS1F404.60
GRS1F404.61
LIST_S(st_gridpoint_code,NRECS)=1 GRS1F404.62
LIST_S(st_weight_code,NRECS)=0 GRS1F404.63
GRS1F404.64
LIST_S(st_input_bottom ,NRECS+1)= GRS1F404.65
& LIST_S(st_output_bottom,NRECS ) GRS1F404.66
LIST_S(st_input_bottom ,NRECS+2)= GRS1F404.67
& LIST_S(st_output_bottom,NRECS+1) GRS1F404.68
GRS1F404.69
LIST_S(st_input_top ,NRECS+1)= GRS1F404.70
& LIST_S(st_output_top ,NRECS ) GRS1F404.71
LIST_S(st_input_top ,NRECS+2)= GRS1F404.72
& LIST_S(st_output_top ,NRECS+1) GRS1F404.73
GRS1F404.74
LIST_S(st_input_code ,NRECS+1)=-NRECS GRS1F404.75
LIST_S(st_input_code ,NRECS+2)=-NRECS-1 GRS1F404.76
LIST_S(st_output_code ,NRECS )=1 GRS1F404.77
LIST_S(st_output_code ,NRECS+1)=1 ! dump GRS1F404.78
LIST_S(st_series_ptr ,NRECS+2)=0 GRS1F404.79
LIST_S(st_series_ptr ,NRECS)=0 GRS1F404.80
LIST_S(NELEMP+1 ,NRECS+1)=NRECS+1 GRS1F404.81
LIST_S(NELEMP+1 ,NRECS+2)=NRECS+2 GRS1F404.82
! definition 8 implies frequency of time mean over every timestep GRS1F404.83
LIST_S(st_freq_code,NRECS)=1 GRS1F404.84
LIST_S(st_freq_code,NRECS+1)= ! Frequency GRS1F404.85
& TOTIMP(ISAM_T(ITIM_L),UNT2_T(ITIM_L),MODL_L) GRS1F404.86
GRS1F404.87
! Correct frequency for radiation, periodic convection, leaf ABX1F405.43
! phenology and vegetation competition ABX1F405.44
GRS1F404.89
IF (ITIMA.EQ.2) THEN GRS1F404.90
LIST_S(st_freq_code,NRECS)=A_LW_RADSTEP GRS1F404.91
ELSE IF(ITIMA.EQ.3) THEN GRS1F404.92
LIST_S(st_freq_code,NRECS)=A_SW_RADSTEP GRS1F404.93
ELSE IF(ITIMA.EQ.13) THEN GRS1F404.94
LIST_S(st_freq_code,NRECS)=A_CONV_STEP GRS1F404.95
ELSE IF(ITIMA.EQ.14) THEN ABX1F405.45
LIST_S(st_freq_code,NRECS)=PHENOL_PERIOD ABX1F405.46
ELSE IF(ITIMA.EQ.15) THEN ABX1F405.47
LIST_S(st_freq_code,NRECS)=TRIFFID_PERIOD ABX1F405.48
END IF GRS1F404.96
GRS1F404.97
! Period GRS1F404.98
! time mean over sampling period GRS1F404.99
LIST_S(st_period_code,NRECS)= GRS1F404.100
& TOTIMP(ISAM_T(ITIM_L),UNT2_T(ITIM_L),MODL_L) GRS1F404.101
! period for timeseries recycle period GRS1F404.102
LIST_S(st_period_code,NRECS+1)= GRS1F404.103
& TOTIMP(INTV_T(ITIM_L),UNT1_T(ITIM_L),MODL_L) GRS1F404.104
GRS1F404.105
! st_start_time for 2 record should be period for first record GRS1F404.106
! unless offset from start of run. Note value independent of logical GRS1F404.107
! OFFSET GRS1F404.108
! GRS1F404.109
IF (LIST_S(st_period_code,NRECS).NE.-1) THEN GRS1F404.110
IF (LOFFSET) THEN GRS1F404.111
LIST_S(st_start_time_code,NRECS+1)= GRS1F404.112
& LIST_S(st_start_time_code,NRECS+1) - GRS1F404.113
& LIST_S(st_period_code,NRECS+1) + GRS1F404.114
& LIST_S(st_freq_code,NRECS+1) - 1 GRS1F404.115
ELSE GRS1F404.116
LIST_S(st_start_time_code,NRECS+1)= GRS1F404.117
& LIST_S(st_start_time_code,NRECS+1) - GRS1F404.118
& LIST_S(st_period_code,NRECS+1) + GRS1F404.119
& LIST_S(st_freq_code,NRECS+1) GRS1F404.120
ENDIF GRS1F404.121
ELSE GRS1F404.122
LIST_S(st_start_time_code,NRECS+1)=1 GRS1F404.123
END IF GRS1F404.124
GRS1F404.125
GRS1F404.126
! Add both record GRS1F404.127
LIST_S(st_macrotag,NRECS)=0 GRS1F404.128
NRECS=NRECS+2 GRS1F404.129
PRELIM1.902
END IF ! Other than single time field PRELIM1.903
PRELIM1.904
END IF ! Diag request not null - ITIM_L.NE.0 PRELIM1.905
999 CONTINUE PRELIM1.906
END DO ! Loop over diagnostic requests PRELIM1.907
PRELIM1.908
END IF ! NDIAG.GT.0 PRELIM1.909
PRELIM1.910
CALL PSLCOM(NRECS) ! Compress out unused pseudo levels lists PRELIM1.911
PRELIM1.912
9999 RETURN GSS1F400.1257
END ! Subroutine PRELIM PRELIM1.914
PRELIM1.915
!- End of Subroutine code ------------------------------------------- PRELIM1.916
PRELIM1.917
PRELIM1.918
!+ Compress out unused pseudo levels lists GSS3F401.973
SUBROUTINE PSLCOM(NRECS) 1PRELIM1.920
PRELIM1.921
! Description: PRELIM1.922
! PRELIM1.923
! Method: PRELIM1.924
! PRELIM1.925
! Current code owner: S.J.Swarbrick PRELIM1.926
! PRELIM1.927
! History: PRELIM1.928
! Version Date Comment PRELIM1.929
! ======= ==== ======= PRELIM1.930
! 3.5 Mar. 95 Original code. S.J.Swarbrick PRELIM1.931
! PRELIM1.932
! Code description: PRELIM1.933
! FORTRAN 77 + common Fortran 90 extensions. PRELIM1.934
! Written to UM programming standards version 7. PRELIM1.935
! PRELIM1.936
! System component covered: PRELIM1.937
! System task: Sub-Models Project PRELIM1.938
! PRELIM1.939
! Global variables: PRELIM1.940
PRELIM1.941
*CALL CSUBMODL PRELIM1.942
*CALL STPARAM PRELIM1.943
*CALL VERSION PRELIM1.944
*CALL CSTASH GRB0F401.20
*CALL STEXTEND PRELIM1.946
PRELIM1.947
! Subroutine arguments: PRELIM1.948
PRELIM1.949
! Scalar arguments with intent(in): PRELIM1.950
PRELIM1.951
INTEGER NRECS PRELIM1.952
PRELIM1.953
! Local Scalars: PRELIM1.954
PRELIM1.955
INTEGER ICOUNT PRELIM1.956
PRELIM1.957
! Local arrays: PRELIM1.958
PRELIM1.959
INTEGER IPOS (NPSLISTP) ! POSITION IN OLD LIST OF THE NEW PRELIM1.960
INTEGER IPOS1(NPSLISTP) ! POSITION IN THE NEW LIST OF THE OLD PRELIM1.961
PRELIM1.962
!- End of Header --------------------------------------------------- PRELIM1.963
PRELIM1.964
PRELIM1.965
ICOUNT=0 PRELIM1.966
PRELIM1.967
DO I=1,NPSLISTS ! LOOP DOWN THE LISTS PRELIM1.968
IF(LENPLST(I).NE.0) THEN ! USED LIST PRELIM1.969
ICOUNT=ICOUNT+1 PRELIM1.970
IPOS(ICOUNT)=I PRELIM1.971
IPOS1(I)=ICOUNT PRELIM1.972
ELSE PRELIM1.973
IPOS1(I)=0 PRELIM1.974
END IF PRELIM1.975
END DO PRELIM1.976
PRELIM1.977
NPSLISTS=ICOUNT PRELIM1.978
PRELIM1.979
DO I=1,NPSLISTS PRELIM1.980
LENPLST(I)=LENPLST(IPOS(I)) PRELIM1.981
DO J=1,NPSLEVP PRELIM1.982
PSLIST_D(J,I)=PSLIST_D(J,IPOS(I)) PRELIM1.983
END DO PRELIM1.984
END DO PRELIM1.985
PRELIM1.986
DO I=NPSLISTS+1,NPSLISTP PRELIM1.987
LENPLST(I)=0 PRELIM1.988
DO J=1,NPSLEVP PRELIM1.989
PSLIST_D(J,I)=0 PRELIM1.990
END DO PRELIM1.991
END DO PRELIM1.992
PRELIM1.993
DO I=1,NRECS PRELIM1.994
IF(LIST_S(st_pseudo_out,I).NE.0) THEN PRELIM1.995
LIST_S(st_pseudo_out,I)=IPOS1(LIST_S(st_pseudo_out,I)) PRELIM1.996
END IF PRELIM1.997
END DO PRELIM1.998
PRELIM1.999
RETURN PRELIM1.1000
END ! Subroutine PSLCOM PRELIM1.1001
PRELIM1.1002
!- End of Subroutine code ------------------------------------------ PRELIM1.1003
*ENDIF PRELIM1.1004