*IF DEF,C84_1A SETLST1A.2
C ******************************COPYRIGHT****************************** GTS2F400.8641
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.8642
C GTS2F400.8643
C Use, duplication or disclosure of this code is subject to the GTS2F400.8644
C restrictions as set forth in the contract. GTS2F400.8645
C GTS2F400.8646
C Meteorological Office GTS2F400.8647
C London Road GTS2F400.8648
C BRACKNELL GTS2F400.8649
C Berkshire UK GTS2F400.8650
C RG12 2SZ GTS2F400.8651
C GTS2F400.8652
C If no contract has been raised with this copy of the code, the use, GTS2F400.8653
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.8654
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.8655
C Modelling at the above address. GTS2F400.8656
C ******************************COPYRIGHT****************************** GTS2F400.8657
C GTS2F400.8658
CLL Subroutine SET_LEVELS_LIST SETLST1A.3
CLL SETLST1A.4
CLL Purpose : To set up a list of levels at which a diagnostic is SETLST1A.5
CLL required, using information in the STASH list. SETLST1A.6
CLL Service routine version for Cray YMP SETLST1A.7
CLL SETLST1A.8
CLL W.Ingram <- programmer of some or all of previous code or changes SETLST1A.9
CLL SETLST1A.10
CLL Model Modification history from model version 3.0: SETLST1A.11
CLL version Date SETLST1A.12
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.177
CLL portability. Author Tracey Smith. TS150793.178
CLL SETLST1A.13
CLL Programming Standard : Unified Model Documentation paper number 4 SETLST1A.14
CLL : Version no 2, dated 18/01/90 SETLST1A.15
CLL SETLST1A.16
CLL System components covered : D3 SETLST1A.17
CLL SETLST1A.18
CLL System task : P0 SETLST1A.19
CLL SETLST1A.20
CLL Documentation: U.M. Documentation paper number P0,C4 SETLST1A.21
CLL SETLST1A.22
CLLEND SETLST1A.23
SETLST1A.24
C*L Arguments SETLST1A.25
SETLST1A.26
SUBROUTINE SET_LEVELS_LIST(LEVELS, 22SETLST1A.27
& LEN_STLIST,STLIST,LIST,STASH_LEVELS, SETLST1A.28
& LEN_STASHLEVELS,ICODE,CMESSAGE) SETLST1A.29
SETLST1A.30
IMPLICIT NONE SETLST1A.31
SETLST1A.32
INTEGER SETLST1A.33
& LEVELS, ! IN Number of levels in input data SETLST1A.34
& LEN_STLIST, ! IN SETLST1A.35
& STLIST(LEN_STLIST), ! IN STASH list SETLST1A.36
& LEN_STASHLEVELS, SETLST1A.37
& STASH_LEVELS(LEN_STASHLEVELS,*), ! IN - list of levels required SETLST1A.38
& ICODE ! OUT Return code =0 Normal exit SETLST1A.39
C >1 Error message SETLST1A.40
SETLST1A.41
LOGICAL SETLST1A.42
& LIST(LEVELS) ! OUT List of levels required. SETLST1A.43
SETLST1A.44
CHARACTER*(80) CMESSAGE ! Error message TS150793.179
SETLST1A.46
CL Local variables SETLST1A.47
SETLST1A.48
INTEGER SETLST1A.49
& K, SETLST1A.50
& KOUT SETLST1A.51
SETLST1A.52
SETLST1A.53
CL Initialise levels list to false SETLST1A.54
SETLST1A.55
DO K=1,LEVELS SETLST1A.56
LIST(K)= .FALSE. SETLST1A.57
END DO SETLST1A.58
SETLST1A.59
CL Check for method of levels selection SETLST1A.60
CL Levels list must be present. SETLST1A.61
SETLST1A.62
IF(STLIST(10).LT.0) THEN SETLST1A.63
SETLST1A.64
C Set logical array list to identify levels required. SETLST1A.65
SETLST1A.66
DO KOUT=2,STASH_LEVELS(1,-STLIST(10))+1 SETLST1A.67
IF((STASH_LEVELS(KOUT,-STLIST(10)).GE.1).AND. SETLST1A.68
& (STASH_LEVELS(KOUT,-STLIST(10)).LE.LEVELS)) THEN SETLST1A.69
C LEVEL IS IN THE RANGE OF LIST. SETLST1A.70
LIST(STASH_LEVELS(KOUT,-STLIST(10))) =.TRUE. SETLST1A.71
ELSE SETLST1A.72
C LEVEL IS OUT OF THE RANGE OF LIST. SETLST1A.73
CMESSAGE= ' SET_LEVELS_LIST: level out of range' SETLST1A.74
WRITE(6,*) ' SET_LEVELS_LIST: level out of range' SETLST1A.75
WRITE(6,*) ' level=',STASH_LEVELS(KOUT,-STLIST(10)) SETLST1A.76
WRITE(6,*) ' Section, Item =',STLIST(2),STLIST(1) SETLST1A.77
ICODE=2 SETLST1A.78
END IF SETLST1A.79
END DO SETLST1A.80
SETLST1A.81
SETLST1A.82
ELSE SETLST1A.83
SETLST1A.84
CL Illegal control data SETLST1A.85
SETLST1A.86
ICODE=1 SETLST1A.87
CMESSAGE='SET_LEVELS_LIST: Illegal control data' SETLST1A.88
WRITE(6,*) 'Illegal control data SET_LEVELS_LIST,STLIST(10,11)=', SETLST1A.89
& STLIST(10) ,STLIST(11) SETLST1A.90
WRITE(6,*) 'Section and item numbers ',STLIST(2),STLIST(1) SETLST1A.91
RETURN SETLST1A.92
SETLST1A.93
END IF SETLST1A.94
SETLST1A.95
RETURN SETLST1A.96
END SETLST1A.97
*ENDIF SETLST1A.98