SUBROUTINE INPUTL(NRECS, 1,19INPUTL1.6
*CALL ARGPPX 
INPUTL1.7
& NLEVELS,ErrorStatus,CMESSAGE) GSS3F401.507
IMPLICIT NONE INPUTL1.9
! Description: INPUTL1.10
! INPUTL1.11
! Method: INPUTL1.12
! INPUTL1.13
! Current code owner: S.J.Swarbrick INPUTL1.14
! INPUTL1.15
! History: INPUTL1.16
! Version Date Comment INPUTL1.17
! ======= ==== ======= INPUTL1.18
! 3.5 Apr. 95 Original code. S.J.Swarbrick INPUTL1.19
! 4.1 Apr. 96 Allow for prognostics with pseudo-levels: GSS3F401.502
! LevFlag=0 now implies input on all available GSS3F401.503
! levels and pseudo-levels. Also other additions GSS3F401.504
! for wave-model grid. GSS3F401.505
! S.J.Swarbrick GSS3F401.506
! 4.2 06/09/96 MPP code : Use local size for calculating GPB1F402.342
! horizontal dimension. P.Burton GPB1F402.343
! INPUTL1.20
! 4.3 30/01/97 Ensure that domain decomposition is consistent GRR0F403.271
! with submodel. R.Rawlins GRR0F403.272
! Code description: INPUTL1.21
! FORTRAN 77 + common Fortran 90 extensions. INPUTL1.22
! Written to UM programming standards version 7. INPUTL1.23
! INPUTL1.24
! System component covered: INPUTL1.25
! System task: Sub-Models Project INPUTL1.26
! INPUTL1.27
! Global variables: INPUTL1.28
INPUTL1.29
*CALL CSUBMODL INPUTL1.30
*CALL CPPXREF GSS3F401.508
*CALL PPXLOOK GSS3F401.509
*CALL TYPSIZE GSS3F401.510
*CALL CSTASH GRB0F401.10
*CALL STEXTEND INPUTL1.33
*CALL MODEL INPUTL1.34
*CALL STPARAM INPUTL1.35
*IF DEF,MPP GPB1F402.344
*CALL PARVARS GPB1F402.345
*CALL DECOMPTP GRR0F403.273
*ENDIF GPB1F402.346
INPUTL1.38
! Subroutine arguments: INPUTL1.39
! Scalar arguments with intent(in): GSS3F401.511
INTEGER NRECS INPUTL1.43
INPUTL1.44
! Scalar arguments with intent(out): INPUTL1.45
INTEGER NLEVELS ! total no. of sets of stash levels GSS3F401.512
INPUTL1.49
! Scalar arguments with intent(out): INPUTL1.50
INPUTL1.51
! ErrorStatus: INPUTL1.52
INTEGER ErrorStatus INPUTL1.53
INPUTL1.54
! Local scalars: INPUTL1.55
LOGICAL MODEL_LEV GSS3F401.513
CHARACTER*80 CMESSAGE GSS9F402.171
LOGICAL LADD INPUTL1.58
LOGICAL LDUPLL INPUTL1.59
INTEGER I,IL,ILIN GSS3F401.514
INTEGER ISTART,IEND GSS3F401.515
INTEGER MODL INPUTL1.63
INTEGER ISEC INPUTL1.64
INTEGER IITM INPUTL1.65
INTEGER IP_IN INPUTL1.68
INTEGER IX1,IX2 GSS3F401.516
INTEGER IY1,IY2 GSS3F401.517
INTEGER IZ_IN INPUTL1.73
INTEGER LEN_IN INPUTL1.74
INTEGER LEN_PRIMIN INPUTL1.75
INTEGER NDUPLL INPUTL1.76
INTEGER NLEVIN INPUTL1.77
INTEGER LENO INPUTL1.78
INTEGER IPF,IPL GSS3F401.518
*IF DEF,MPP GPB1F402.347
! local versions of the global subdomain limits GPB1F402.348
INTEGER local_IX1,local_IX2,local_IY1,local_IY2 GPB1F402.349
INTEGER GRR0F403.274
& orig_decomp ! MPP decomposition before start GRR0F403.275
& ,decomp_type ! decomposition type GRR0F403.276
& ,sm_ident ! submodel identifier GRR0F403.277
*ENDIF GPB1F402.350
INPUTL1.79
! Function and subroutine calls: INPUTL1.80
LOGICAL DISCT_LEV GSS3F401.519
INTEGER EXPPXI INPUTL1.82
EXTERNAL EXPPXI,LEVSRT,LLTORC,ADDRLN,OCNVOL GSS3F401.520
*IF DEF,MPP GRR0F403.278
External CHANGE_DECOMPOSITION,GLOBAL_TO_LOCAL_SUBDOMAIN GRR0F403.279
*ENDIF GRR0F403.280
INPUTL1.84
!- End of Header ---------------------------------------------------- INPUTL1.85
INPUTL1.87
*IF DEF,MPP GRR0F403.281
orig_decomp = current_decomp_type GRR0F403.282
*ENDIF GRR0F403.283
GRR0F403.284
DO MODL=1,N_INTERNAL_MODEL_MAX INPUTL1.88
*IF DEF,MPP GRR0F403.285
! GRR0F403.286
! Ensure that domain decomposition is consistent with submodel GRR0F403.287
! GRR0F403.288
sm_ident = SUBMODEL_PARTITION_INDEX(MODL) GRR0F403.289
IF(sm_ident.EQ.atmos_sm) THEN GRR0F403.290
decomp_type = decomp_standard_atmos GRR0F403.291
ELSEIF(sm_ident.EQ.ocean_sm) THEN GRR0F403.292
decomp_type = decomp_standard_ocean GRR0F403.293
ELSE ! No decomposition defined: GRR0F403.294
decomp_type = orig_decomp ! return to original GRR0F403.295
ENDIF GRR0F403.296
GRR0F403.297
CALL CHANGE_DECOMPOSITION(decomp_type,ErrorStatus) GRR0F403.298
GRR0F403.299
IF(ErrorStatus.GT.0) THEN GRR0F403.300
CMESSAGE='INPUTL: ERROR in changing MPP decomposition' GRR0F403.301
write(6,*) CMESSAGE GRR0F403.302
GOTO 999 GRR0F403.303
ENDIF GRR0F403.304
*ENDIF GRR0F403.305
DO ISEC=0,PPXREF_SECTIONS INPUTL1.89
DO IITM=1,PPXREF_ITEMS INPUTL1.90
IF(INDX_S(2,MODL,ISEC,IITM).GE.1) THEN INPUTL1.92
! At least one stash rec INPUTL1.93
IGP = EXPPXI(MODL,ISEC,IITM,ppx_grid_type , GSS3F401.521
*CALL ARGPPX INPUTL1.98
& ErrorStatus,CMESSAGE) INPUTL1.99
ILEV = EXPPXI(MODL,ISEC,IITM,ppx_lv_code , GSS3F401.522
*CALL ARGPPX INPUTL1.101
& ErrorStatus,CMESSAGE) INPUTL1.102
IFLAG = EXPPXI(MODL,ISEC,IITM,ppx_lev_flag , GSS3F401.523
*CALL ARGPPX INPUTL1.104
& ErrorStatus,CMESSAGE) INPUTL1.105
IPSEUDO = EXPPXI(MODL,ISEC,IITM,ppx_pt_code , GSS3F401.524
*CALL ARGPPX ORH5F400.19
& ErrorStatus,CMESSAGE) GSS3F401.525
IPFIRST = EXPPXI(MODL,ISEC,IITM,ppx_pf_code , GSS3F401.526
*CALL ARGPPX GSS3F401.527
& ErrorStatus,CMESSAGE) GSS3F401.528
IPLAST = EXPPXI(MODL,ISEC,IITM,ppx_pl_code , GSS3F401.529
*CALL ARGPPX GSS3F401.530
& ErrorStatus,CMESSAGE) GSS3F401.531
INPUTL1.106
ISTART= INDX_S(1,MODL,ISEC,IITM) ! Pos of 1st rec INPUTL1.107
IEND =ISTART+INDX_S(2,MODL,ISEC,IITM)-1 ! Pos of last rec INPUTL1.108
! Diagnostics with input on levels list (IFLAG=1), GSS3F401.532
! rather than on all possible levels GSS3F401.533
IF((IFLAG .EQ.1 ).AND. !Input on lev list GSS3F401.534
& (ISTART.EQ.IEND).AND. !Only 1 stash rec GSS3F401.535
& (LIST_S(st_output_bottom,ISTART).LT.0))!Output on lev list GSS3F401.536
& THEN GSS3F401.537
! Only one stash record for this m,s,i - output levels list is GSS3F401.538
! the same as the input levels list GSS3F401.539
LIST_S(st_input_bottom ,ISTART)= INPUTL1.116
& LIST_S(st_output_bottom,ISTART) INPUTL1.117
ELSE IF (IFLAG.EQ.1.AND.ILEV.NE.5) THEN GSS3F401.540
! Input on levels list & more than one stash request - GSS3F401.541
! construct input levels list GSS3F401.542
NLEVELS=NLEVELS+1 GSS3F401.543
IF (NLEVELS.GT.NLEVLSTSP) THEN INPUTL1.123
WRITE(6,*) 'ERROR IN ROUTINE INPUTL:' GSS3F401.544
WRITE(6,*) 'TOO MANY STASH LEVELS LISTS REQUESTED ', GSS3F401.545
& 'ARRAYS WILL BE OVERWRITTEN' GSS3F401.546
WRITE(6,*) 'REDUCE NUMBER OF LEVELS LISTS' GSS3F401.547
ErrorStatus=1 GSS3F401.548
GO TO 999 GSS3F401.549
END IF INPUTL1.127
! Construct input levels list: this is the combined list of all GSS3F401.550
! the output levels for all the stash requests for this m,s,i GSS3F401.551
NLEVIN=1 INPUTL1.129
! Set levels list type - real or integer GSS3F401.552
MODEL_LEV=DISCT_LEV(ILEV,ErrorStatus,CMESSAGE) GSS3F401.553
IF (.NOT.MODEL_LEV) THEN GSS3F401.554
! Non-model levels - real GSS3F401.555
LLISTTY(NLEVELS)='R' GSS3F401.556
! Model levels - integer GSS3F401.557
ELSE INPUTL1.137
LLISTTY(NLEVELS)='I' GSS3F401.558
END IF INPUTL1.140
! Loop over stash recs for this m,s,i GSS3F401.559
DO I=ISTART,IEND GSS3F401.560
! Pointer for input level list GSS3F401.561
LIST_S(st_input_bottom,I)=-NLEVELS GSS3F401.562
IF (LIST_S(st_output_bottom,I).LT.0) THEN GSS3F401.563
! There is an output levels list: GSS3F401.564
! For each of the levels in the output levels lists for the stash GSS3F401.565
! record I, find out whether this level is already present in the GSS3F401.566
! input levels list NLEVELS constructed so far. GSS3F401.567
! If it is, set LADD=F. Otherwise, LADD=T. INPUTL1.152
! Loop over output levels and check each one GSS3F401.568
DO IL=2,LEVLST_S(1,-LIST_S(st_output_bottom,I))+1 INPUTL1.155
LADD=.TRUE. GSS3F401.569
IF(NLEVIN.GT.1) THEN INPUTL1.159
DO ILIN=2,NLEVIN INPUTL1.160
IF(LIST_S(st_output_top,I).NE.1) THEN INPUTL1.161
! Non-model levels: real GSS3F401.570
IF(RLEVLST_S(IL,-LIST_S(st_output_bottom,I)) INPUTL1.163
& .EQ. INPUTL1.164
& RLEVLST_S(ILIN,NLEVELS)) LADD=.FALSE. INPUTL1.165
ELSE GSS3F401.571
! Model levels: integer GSS3F401.572
IF( LEVLST_S(IL,-LIST_S(st_output_bottom,I)) INPUTL1.167
& .EQ. INPUTL1.168
& LEVLST_S(ILIN,NLEVELS)) LADD=.FALSE. INPUTL1.169
END IF INPUTL1.170
END DO INPUTL1.171
END IF INPUTL1.172
INPUTL1.173
! If LADD=T, add level 'IL' from stash record 'I' output levels list INPUTL1.174
! to input levels list NLEVELS GSS3F401.573
IF (LADD) THEN INPUTL1.177
NLEVIN=NLEVIN+1 INPUTL1.178
IF(LIST_S(st_output_top,I).NE.1) THEN INPUTL1.179
RLEVLST_S(NLEVIN,NLEVELS)= INPUTL1.181
& RLEVLST_S(IL,-LIST_S(st_output_bottom,I)) INPUTL1.182
ELSE GSS3F401.574
LEVLST_S(NLEVIN,NLEVELS)= INPUTL1.184
& LEVLST_S(IL,-LIST_S(st_output_bottom,I)) INPUTL1.185
END IF INPUTL1.186
END IF INPUTL1.187
END DO ! Loop over levels INPUTL1.189
INPUTL1.190
ELSE GSS3F401.575
! Contiguous range of model levels for output, rather than list GSS3F401.576
! Compare output levels range for stash record I with input levs GSS3F401.577
! range NLEVELS. Any of the output levels not already present GSS3F401.578
! in the input range is added to the input list. GSS3F401.579
DO IL=LIST_S(st_output_bottom,I), INPUTL1.197
& LIST_S(st_output_top ,I) INPUTL1.198
LADD=.TRUE. INPUTL1.199
DO ILIN=2,NLEVIN INPUTL1.200
IF(IL.EQ.LEVLST_S(ILIN,NLEVELS)) LADD=.FALSE. INPUTL1.201
END DO INPUTL1.202
IF(LADD) THEN INPUTL1.203
NLEVIN=NLEVIN+1 INPUTL1.204
LEVLST_S(NLEVIN,NLEVELS)=IL INPUTL1.205
END IF INPUTL1.206
END DO INPUTL1.207
END IF ! Levels list/range GSS3F401.580
END DO ! Loop over stash recs INPUTL1.211
INPUTL1.212
! Record no. of levels in input list just constructed GSS3F401.581
LEVLST_S(1,NLEVELS)=NLEVIN-1 GSS3F401.582
INPUTL1.214
IF(NLEVIN-1.EQ.0) THEN GSS3F401.583
WRITE(6,*) 'ORDINARY LEVEL' INPUTL1.217
WRITE(6,*) 'ISEC=',ISEC INPUTL1.218
WRITE(6,*) 'IITM=',IITM INPUTL1.219
WRITE(6,*) 'NLEVELS=',NLEVELS INPUTL1.220
DO I=ISTART,IEND GSS3F401.584
WRITE(6,*) 'I=',I GSS3F401.585
WRITE(6,*) 'LIST_S(st_output_bottom)=', INPUTL1.224
& LIST_S(st_output_bottom,I) INPUTL1.225
IF (LIST_S(st_output_bottom,I).LT.0) THEN INPUTL1.226
DO IL=2,LEVLST_S(1,-LIST_S(st_output_bottom,I))+1 INPUTL1.227
WRITE(6,*) 'IL=',IL INPUTL1.228
WRITE(6,*) INPUTL1.229
& 'LEVLST',LEVLST_S(IL,-LIST_S(st_output_bottom,I)) INPUTL1.230
END DO INPUTL1.231
ELSE INPUTL1.232
WRITE(6,*) INPUTL1.233
& 'LIST_S(st_output_top=',LIST_S(st_output_top,I) INPUTL1.234
END IF INPUTL1.235
END DO INPUTL1.236
END IF INPUTL1.238
! Sort levels list INPUTL1.239
CALL LEVSRT(LLISTTY( NLEVELS), LEVLST_S(1,NLEVELS), INPUTL1.240
& LEVLST_S(2,NLEVELS),RLEVLST_S(2,NLEVELS)) INPUTL1.241
INPUTL1.242
! Determine whether this levels list is a duplicate of another list INPUTL1.243
CALL DUPLEVL(NLEVELS,LDUPLL,NDUPLL) INPUTL1.245
IF (LDUPLL) THEN GSS3F401.586
! Duplicate list at NDUPLL - reset pointer and reduce NLEVELS by 1 GSS3F401.587
NLEVELS=NLEVELS-1 INPUTL1.248
DO I=ISTART,IEND INPUTL1.249
LIST_S(st_input_bottom,I)=-NDUPLL INPUTL1.250
END DO INPUTL1.251
END IF INPUTL1.252
END IF !Levels lists GSS3F401.588
INPUTL1.255
! Pseudo levels lists INPUTL1.256
IF((IFLAG .EQ.1 ).AND. GSS3F401.589
& ((ISTART.EQ.IEND).OR.(IPSEUDO.EQ.0)) ) THEN GSS3F401.590
! Either no pseudo levels or only one request: GSS3F401.591
! Input pseudo levels list equals output list GSS3F401.592
LIST_S(st_pseudo_in,ISTART)=LIST_S(st_pseudo_out,ISTART) INPUTL1.260
ELSE IF (IFLAG.EQ.1) THEN GSS3F401.593
! Input pseudo levels list with more than one request GSS3F401.594
NPSLISTS=NPSLISTS+1 INPUTL1.264
IF(NPSLISTS.GT.NPSLISTP) THEN INPUTL1.266
WRITE(6,*) 'ERROR IN ROUTINE INPUTL:' GSS3F401.595
WRITE(6,*) GSS3F401.596
& 'TOO MANY STASH PSEUDO LEVELS LISTS REQUESTED ', GSS3F401.597
& 'ARRAYS WILL BE OVERWRITTEN' GSS3F401.598
WRITE(6,*) 'REDUCE NUMBER OF PSEUDO LISTS' GSS3F401.599
ErrorStatus=1 GSS3F401.600
GO TO 999 GSS3F401.601
END IF INPUTL1.269
! Construct input pseudo list: combined list of all output GSS3F401.602
! pseudo levels for all stash requests for this m,s,i GSS3F401.603
NLEVIN=0 INPUTL1.271
DO I=ISTART,IEND INPUTL1.273
LIST_S(st_pseudo_in,I)=NPSLISTS INPUTL1.274
DO IL=1,LENPLST(LIST_S(st_pseudo_out,I)) INPUTL1.275
LADD=.TRUE. INPUTL1.276
IF(NLEVIN.GT.0) THEN INPUTL1.277
DO ILIN=1,NLEVIN INPUTL1.278
IF( PSLIST_D(IL,LIST_S(st_pseudo_out,I)).EQ. INPUTL1.279
& PSLIST_D(ILIN,NPSLISTS)) LADD=.FALSE. INPUTL1.280
END DO INPUTL1.281
END IF INPUTL1.282
IF(LADD) THEN INPUTL1.283
NLEVIN=NLEVIN+1 INPUTL1.284
PSLIST_D(NLEVIN,NPSLISTS)= INPUTL1.285
& PSLIST_D(IL,LIST_S(st_pseudo_out,I)) INPUTL1.286
END IF INPUTL1.287
END DO INPUTL1.288
END DO INPUTL1.289
LENPLST(NPSLISTS)=NLEVIN INPUTL1.291
INPUTL1.292
IF(NLEVIN.EQ.0) THEN INPUTL1.293
WRITE(6,*) 'PSEUDO LEVEL' INPUTL1.295
WRITE(6,*) 'ISEC=',ISEC INPUTL1.296
WRITE(6,*) 'IITM=',IITM INPUTL1.297
WRITE(6,*) 'NPSLISTS=',NPSLISTS INPUTL1.298
DO I=ISTART,IEND INPUTL1.300
WRITE(6,*) 'I=',I INPUTL1.301
WRITE(6,*) 'LENPLST=',LENPLST(LIST_S(st_pseudo_out,I)) INPUTL1.302
DO IL=1,LENPLST(LIST_S(st_pseudo_out,I)) INPUTL1.303
WRITE(6,*) 'IL=',IL INPUTL1.304
WRITE(6,*) INPUTL1.305
& 'PSLIST_D',PSLIST_D(IL,LIST_S(st_pseudo_out,I)) INPUTL1.306
END DO INPUTL1.307
END DO INPUTL1.308
END IF INPUTL1.310
! Sort input pseudo levels list GSS3F401.604
CALL LEVSRT('I',LENPLST(NPSLISTS),PSLIST_D(1,NPSLISTS), INPUTL1.312
& PSLIST_D(1,NPSLISTS)) INPUTL1.313
! Find out if duplicate GSS3F401.605
CALL DUPPSLL(LDUPLL,NDUPLL) INPUTL1.315
IF(LDUPLL) THEN GSS3F401.606
! Duplicate pseudo list at NDUPLL GSS3F401.607
NPSLISTS=NPSLISTS-1 INPUTL1.318
DO I=ISTART,IEND INPUTL1.319
LIST_S(st_pseudo_in,I)=NDUPLL INPUTL1.320
END DO INPUTL1.321
END IF INPUTL1.322
ELSE IF (IFLAG.EQ.0.AND.IPSEUDO.NE.0) THEN GSS3F401.608
! Input pseudo levels list contains all possible pseudo levels for GSS3F401.609
! this diagnostic GSS3F401.610
NPSLISTS=NPSLISTS+1 GSS3F401.611
DO I=ISTART,IEND GSS3F401.612
LIST_S(st_pseudo_in,I)=NPSLISTS GSS3F401.613
! Decode first & last pseudo level codes from stash master GSS3F401.614
CALL PSLEVCOD(IPFIRST,IPF,'F',ErrorStatus,CMESSAGE) GSS3F401.615
CALL PSLEVCOD(IPLAST ,IPL,'L',ErrorStatus,CMESSAGE) GSS3F401.616
! Construct list GSS3F401.617
DO NLEVIN = IPF,IPL GSS3F401.618
PSLIST_D(NLEVIN,NPSLISTS)=NLEVIN GSS3F401.619
END DO GSS3F401.620
END DO GSS3F401.621
LENPLST(NPSLISTS)=IPL-IPF+1 GSS3F401.622
END IF ! Pseudo levels INPUTL1.324
INPUTL1.325
! Calculate horizontal factor for input length INPUTL1.326
CALL LLTORC(IGP,90,-90,0,360,IY1,IY2,IX1,IX2) GSS3F401.623
GPB1F402.351
*IF DEF,MPP GPB1F402.352
! Convert from global to local subdomain limits GPB1F402.353
CALL GLOBAL_TO_LOCAL_SUBDOMAIN( .TRUE., .TRUE., GPB1F402.354
& IGP,mype, GPB1F402.355
& IY1,IX2,IY2,IX1, GPB1F402.356
& local_IY1,local_IX2, GPB1F402.357
& local_IY2,local_IX1) GPB1F402.358
IX1=local_IX1 GPB1F402.359
IX2=local_IX2 GPB1F402.360
IY1=local_IY1 GPB1F402.361
IY2=local_IY2 GPB1F402.362
*ENDIF GPB1F402.363
IF (IGP.GE.60.AND.IGP.LT.70) THEN GSS3F401.624
!Wave model grid - first lat is southern most GSS3F401.625
LEN_IN=(IX2-IX1+1)*(IY1-IY2+1) GSS3F401.626
ELSE GSS3F401.627
!Atmos grid - first lat is northern most GSS3F401.628
LEN_IN=(IX2-IX1+1)*(IY2-IY1+1) GSS3F401.629
END IF GSS3F401.630
INPUTL1.331
! Calculate vertical levels factor for input length INPUTL1.332
IF(ILEV.NE.5) THEN GSS3F401.631
! More than one level GSS3F401.632
IF(LIST_S(st_input_bottom,ISTART).LT.0) THEN GSS3F401.633
! Level list GSS3F401.634
IZ_IN=LEVLST_S(1,-LIST_S(st_input_bottom,ISTART)) GSS3F401.635
ELSE GSS3F401.636
! Range of model levs GSS3F401.637
IZ_IN=LIST_S(st_input_top ,ISTART)- GSS3F401.638
& LIST_S(st_input_bottom,ISTART)+1 GSS3F401.639
END IF INPUTL1.340
ELSE GSS3F401.640
! Single level input GSS3F401.641
IZ_IN=1 INPUTL1.342
END IF INPUTL1.343
INPUTL1.344
! Calculate pseudo levels factor for input length INPUTL1.345
IF(IPSEUDO.NE.0) THEN INPUTL1.347
IP_IN=LENPLST(LIST_S(st_pseudo_in,ISTART)) INPUTL1.348
ELSE INPUTL1.349
IP_IN=1 INPUTL1.350
END IF INPUTL1.351
INPUTL1.352
! Calculate input length for this diag. and store in LIST_S INPUTL1.353
! Input_code.lt.0 means that a diag already processed into D1 is being INPUTL1.354
! reprocessed, so input length of child diag equals output length of INPUTL1.355
! parent. INPUTL1.356
! Otherwise, the input len is given by the product of the appropriate INPUTL1.357
! x-,y-,z-, and p-dimensions. INPUTL1.358
DO I=ISTART,IEND INPUTL1.360
IF(LIST_S(st_input_code ,I).GE.0) THEN INPUTL1.361
LIST_S(st_input_length,I)=LEN_IN*IZ_IN*IP_IN INPUTL1.362
ELSE INPUTL1.363
LIST_S(st_input_length ,I)= INPUTL1.364
& LIST_S(st_output_length,-LIST_S(st_input_code,I)) INPUTL1.365
END IF INPUTL1.366
! Store model no. in last element of LIST_S - for ADDRES GSS3F401.642
LIST_S(NELEMP+1,I)=MODL GSS3F401.643
END DO GSS3F401.644
INPUTL1.369
! Recalculate input length for non-primary (length unchanged for INPUTL1.370
! most cases) and store in IN_S array. INPUTL1.371
IF (ISEC.NE.0) THEN INPUTL1.373
IF ((IGP.NE.31).AND.(IGP.NE.32))THEN INPUTL1.374
CALL ADDRLN(IGP,LEN_PRIMIN, GPB1F402.364
*IF DEF,MPP GPB1F402.365
& local_data, GPB1F402.366
*ENDIF GPB1F402.367
& ErrorStatus) GPB1F402.368
IN_S(2,MODL,ISEC,IITM)=LEN_PRIMIN*IZ_IN*IP_IN INPUTL1.376
ELSE INPUTL1.377
CALL OCNVOL(LENO,LIST_S(st_input_bottom,ISTART), INPUTL1.378
& LIST_S(st_input_top ,ISTART)) INPUTL1.379
IN_S(2,MODL,ISEC,IITM)=LENO INPUTL1.380
END IF INPUTL1.381
END IF INPUTL1.382
INPUTL1.383
END IF ! At least one stash record for m,s,i INPUTL1.384
INPUTL1.385
END DO ! Items INPUTL1.386
END DO ! Sections INPUTL1.387
END DO ! Models INPUTL1.388
*IF DEF,MPP GRR0F403.306
! GRR0F403.307
CALL CHANGE_DECOMPOSITION(orig_decomp,ErrorStatus) GRR0F403.308
GRR0F403.309
IF(ErrorStatus.GT.0) THEN GRR0F403.310
CMESSAGE='INPUTL: ERROR in original MPP decomposition' GRR0F403.311
write(6,*) CMESSAGE GRR0F403.312
GOTO 999 GRR0F403.313
ENDIF GRR0F403.314
*ENDIF GRR0F403.315
INPUTL1.389
999 CONTINUE GSS3F401.645
GSS3F401.646
RETURN INPUTL1.390
END INPUTL1.391
INPUTL1.392
!- End of subroutine code ------------------------------------------- INPUTL1.393
INPUTL1.394
INPUTL1.395
!+Determine whether a levels list is a duplicate of another levels list INPUTL1.396
! Subroutine Interface: INPUTL1.397
INPUTL1.398
SUBROUTINE DUPLEVL(NLEVELS,LDUPLL,NDUPLL) 1INPUTL1.399
IMPLICIT NONE INPUTL1.400
! Description: INPUTL1.401
! INPUTL1.402
! Method: INPUTL1.403
! INPUTL1.404
! Current code owner: S.J.Swarbrick INPUTL1.405
! INPUTL1.406
! History: INPUTL1.407
! Version Date Comment INPUTL1.408
! ======= ==== ======= INPUTL1.409
! 3.5 Apr. 95 Original code. S.J.Swarbrick INPUTL1.410
! INPUTL1.411
! Code description: INPUTL1.412
! FORTRAN 77 + common Fortran 90 extensions. INPUTL1.413
! Written to UM programming standards version 7. INPUTL1.414
! INPUTL1.415
! System component covered: INPUTL1.416
! System task: Sub-Models Project INPUTL1.417
! INPUTL1.418
! Global variables: INPUTL1.419
INPUTL1.420
*CALL CSUBMODL INPUTL1.421
*CALL VERSION INPUTL1.422
*CALL CSTASH GRB0F401.11
*CALL STEXTEND INPUTL1.424
INPUTL1.425
! Subroutine arguments: INPUTL1.426
INPUTL1.427
! Scalar arguments with intent(in): INPUTL1.428
INPUTL1.429
INTEGER NLEVELS INPUTL1.430
INPUTL1.431
! Scalar arguments with intent(out): INPUTL1.432
INPUTL1.433
LOGICAL LDUPLL INPUTL1.434
LOGICAL LLOCAL INPUTL1.435
INTEGER NDUPLL INPUTL1.436
INPUTL1.437
! Local scalars: INPUTL1.438
INPUTL1.439
INTEGER I INPUTL1.440
INTEGER J INPUTL1.441
INPUTL1.442
!- End of Header ----------------------------------------------------- INPUTL1.443
INPUTL1.444
LDUPLL=.FALSE. INPUTL1.445
NDUPLL=0 INPUTL1.446
DO 100 I=1,NLEVELS-1 INPUTL1.447
IF((LEVLST_S(1,I).EQ.LEVLST_S(1,NLEVELS)).AND. INPUTL1.448
& (LLISTTY(I).EQ.LLISTTY(NLEVELS))) THEN INPUTL1.449
LLOCAL=.TRUE. INPUTL1.450
DO 200 J=2,LEVLST_S(1,NLEVELS)+1 INPUTL1.451
IF(LLISTTY(NLEVELS).EQ.'I') THEN INPUTL1.452
IF(LEVLST_S(J,I).NE.LEVLST_S(J,NLEVELS)) THEN INPUTL1.453
LLOCAL=.FALSE. INPUTL1.454
GOTO 210 INPUTL1.455
END IF INPUTL1.456
ELSE INPUTL1.457
IF(RLEVLST_S(J,I).NE.RLEVLST_S(J,NLEVELS)) THEN INPUTL1.458
LLOCAL=.FALSE. INPUTL1.459
GOTO 210 INPUTL1.460
END IF INPUTL1.461
END IF INPUTL1.462
200 CONTINUE INPUTL1.463
210 CONTINUE INPUTL1.464
IF(LLOCAL) THEN INPUTL1.465
LDUPLL=.TRUE. INPUTL1.466
NDUPLL=I INPUTL1.467
RETURN INPUTL1.468
END IF INPUTL1.469
END IF INPUTL1.470
100 CONTINUE INPUTL1.471
RETURN INPUTL1.472
END INPUTL1.473
INPUTL1.474
!- End of subroutine code ---------------------------------------- INPUTL1.475
INPUTL1.476
INPUTL1.477
!+Determine whether a pseudo lev list is a duplicate of another one INPUTL1.478
! Subroutine Interface: INPUTL1.479
INPUTL1.480
SUBROUTINE DUPPSLL(LDUPLL,NDUPLL) 1INPUTL1.481
IMPLICIT NONE INPUTL1.482
! Description: INPUTL1.483
! INPUTL1.484
! Method: INPUTL1.485
! INPUTL1.486
! Current code owner: S.J.Swarbrick INPUTL1.487
! INPUTL1.488
! History: INPUTL1.489
! Version Date Comment INPUTL1.490
! ======= ==== ======= INPUTL1.491
! 3.5 Apr. 95 Original code. S.J.Swarbrick INPUTL1.492
! INPUTL1.493
! Code description: INPUTL1.494
! FORTRAN 77 + common Fortran 90 extensions. INPUTL1.495
! Written to UM programming standards version 7. INPUTL1.496
! INPUTL1.497
! System component covered: INPUTL1.498
! System task: Sub-Models Project INPUTL1.499
! INPUTL1.500
! Global variables: INPUTL1.501
INPUTL1.502
*CALL CSUBMODL INPUTL1.503
*CALL VERSION INPUTL1.504
*CALL CSTASH GRB0F401.12
*CALL STEXTEND INPUTL1.506
INPUTL1.507
! Subroutine arguments: INPUTL1.508
INPUTL1.509
! Scalar arguments with intent(out): INPUTL1.510
INPUTL1.511
LOGICAL LDUPLL INPUTL1.512
LOGICAL LLOCAL INPUTL1.513
INTEGER NDUPLL INPUTL1.514
INPUTL1.515
! Local scalars: INPUTL1.516
INPUTL1.517
INTEGER I INPUTL1.518
INTEGER J INPUTL1.519
INPUTL1.520
!- End of Header ------------------------------------------------- INPUTL1.521
INPUTL1.522
INPUTL1.523
LDUPLL=.FALSE. INPUTL1.524
NDUPLL=0 INPUTL1.525
DO 100 I=1,NPSLISTS-1 INPUTL1.526
IF(LENPLST(I).EQ.LENPLST(NPSLISTS)) THEN INPUTL1.527
LLOCAL=.TRUE. INPUTL1.528
DO 200 J=1,LENPLST(NPSLISTS) INPUTL1.529
IF(PSLIST_D(J,I).NE.PSLIST_D(J,NPSLISTS)) THEN INPUTL1.530
LLOCAL=.FALSE. INPUTL1.531
GOTO 210 INPUTL1.532
END IF INPUTL1.533
200 CONTINUE INPUTL1.534
210 CONTINUE INPUTL1.535
IF(LLOCAL) THEN INPUTL1.536
LDUPLL=.TRUE. INPUTL1.537
NDUPLL=I INPUTL1.538
RETURN INPUTL1.539
END IF INPUTL1.540
END IF INPUTL1.541
100 CONTINUE INPUTL1.542
INPUTL1.543
INPUTL1.544
RETURN INPUTL1.545
END INPUTL1.546
INPUTL1.547
!- End of subroutine code --------------------------------------- INPUTL1.548
*ENDIF INPUTL1.549