*IF DEF,C84_1A SETPLS1A.2
C ******************************COPYRIGHT****************************** GTS2F400.8659
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.8660
C GTS2F400.8661
C Use, duplication or disclosure of this code is subject to the GTS2F400.8662
C restrictions as set forth in the contract. GTS2F400.8663
C GTS2F400.8664
C Meteorological Office GTS2F400.8665
C London Road GTS2F400.8666
C BRACKNELL GTS2F400.8667
C Berkshire UK GTS2F400.8668
C RG12 2SZ GTS2F400.8669
C GTS2F400.8670
C If no contract has been raised with this copy of the code, the use, GTS2F400.8671
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.8672
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.8673
C Modelling at the above address. GTS2F400.8674
C ******************************COPYRIGHT****************************** GTS2F400.8675
C GTS2F400.8676
CLL Subroutine SET_PSEUDO_LIST ----------------------------------------- SETPLS1A.3
CLL SETPLS1A.4
CLL Purpose : To set up a list of pseudo levels at which a diagnostic SETPLS1A.5
CLL is required, using information in the STASH list. SETPLS1A.6
CLL SETPLS1A.7
CLL Service routine SETPLS1A.8
CLL SETPLS1A.9
CLL Written by D Robinson 7/10/92 SETPLS1A.10
CLL Copy of Subroutine SET_LEVELS_LIST (Deck SETLST1) taken and SETPLS1A.11
CLL adapted for pseudo levels. SETPLS1A.12
CLL SETPLS1A.13
CLL Model Modification history from model version 3.0: SETPLS1A.14
CLL version Date SETPLS1A.15
CLL 3.1 12/1/93 : More error checking . Dave Robinson SB230293.1222
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.180
CLL portability. Author Tracey Smith. TS150793.181
CLL SETPLS1A.16
CLL Programming Standard : Unified Model Documentation paper number 3 SETPLS1A.17
CLL : Version no 4, dated 5/2/92 SETPLS1A.18
CLL SETPLS1A.19
CLL Logical components covered : D3 SETPLS1A.20
CLL SETPLS1A.21
CLL System task : P0 SETPLS1A.22
CLL SETPLS1A.23
CLL Documentation: U.M. Documentation paper number P0,C4 SETPLS1A.24
CLL SETPLS1A.25
CLLEND ----------------------------------------------------------------- SETPLS1A.26
C SETPLS1A.27
C*L Arguments SETPLS1A.28
SETPLS1A.29
SUBROUTINE SET_PSEUDO_LIST 32SETPLS1A.30
& (N_LEVELS,LEN_STLIST,STLIST,PSEUDO_LIST, SETPLS1A.31
& STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO,ICODE,CMESSAGE) SETPLS1A.32
SETPLS1A.33
IMPLICIT NONE SETPLS1A.34
SETPLS1A.35
INTEGER SETPLS1A.36
& N_LEVELS ! IN Number of possible pseudo levels SETPLS1A.37
&, LEN_STLIST ! IN Dimension of STLIST SETPLS1A.38
&, STLIST(LEN_STLIST) ! IN STASH list SETPLS1A.39
&, NUM_STASH_PSEUDO ! IN Dimension for STASH_PSEUDO_LEVELS SETPLS1A.40
&, STASH_PSEUDO_LEVELS(NUM_STASH_PSEUDO+1,*) ! IN Pseudo levels SETPLS1A.41
&, ICODE ! OUT Return code SETPLS1A.42
SETPLS1A.43
LOGICAL SETPLS1A.44
& PSEUDO_LIST(N_LEVELS) ! OUT List of pseudo levels required. SETPLS1A.45
SETPLS1A.46
CHARACTER*(80) CMESSAGE ! Error message TS150793.182
SETPLS1A.48
C* --------------------------------------------------------------------- SETPLS1A.49
SETPLS1A.50
C*L Workspace Usage :- None SETPLS1A.51
SETPLS1A.52
C*L External Subroutines called :- None SETPLS1A.53
SETPLS1A.54
*CALL STPARAM 
SETPLS1A.55
C* --------------------------------------------------------------------- SETPLS1A.56
C Local variables SETPLS1A.57
SETPLS1A.58
INTEGER SETPLS1A.59
& JLEV ! Loop counter over levels SETPLS1A.60
&, LEVEL_NO ! Level no in pseudo list SETPLS1A.61
&, LIST_NO ! Pseudo level list number SETPLS1A.62
SETPLS1A.63
C* --------------------------------------------------------------------- SETPLS1A.64
SETPLS1A.65
CL Initialise pseudo levels list to false SETPLS1A.66
SETPLS1A.67
DO JLEV=1,N_LEVELS SETPLS1A.68
PSEUDO_LIST(JLEV)= .FALSE. SETPLS1A.69
END DO SETPLS1A.70
SETPLS1A.71
CL Get pseudo list number SETPLS1A.72
SETPLS1A.73
LIST_NO = STLIST(ST_PSEUDO_IN) SETPLS1A.74
SETPLS1A.75
CL Check that Pseudo list number is valid (should be GE 0) SETPLS1A.76
SETPLS1A.77
IF (LIST_NO.LT.0) THEN SETPLS1A.78
SETPLS1A.79
C Illegal control data SETPLS1A.80
SETPLS1A.81
ICODE=1 SETPLS1A.82
CMESSAGE = 'SET_PSEUDO_LIST: Illegal control data' SETPLS1A.83
WRITE(6,*) 'SET_PSEUDO_LIST: Illegal control data' SETPLS1A.84
WRITE(6,*) 'ST_PSEUDO_IN = ',ST_PSEUDO_IN SETPLS1A.85
WRITE(6,*) 'STLIST(ST_PSEUDO_IN) = ',STLIST(ST_PSEUDO_IN) SETPLS1A.86
WRITE(6,*) 'Section and item numbers ',STLIST(2),STLIST(1) SETPLS1A.87
GO TO 999 ! Return SETPLS1A.88
SETPLS1A.89
ENDIF SETPLS1A.90
SETPLS1A.91
C Set logical array list to identify pseudo levels required. SETPLS1A.92
SETPLS1A.93
IF (LIST_NO.GT.0) THEN SETPLS1A.94
SETPLS1A.95
DO JLEV=2,STASH_PSEUDO_LEVELS(1,LIST_NO)+1 SETPLS1A.96
LEVEL_NO = STASH_PSEUDO_LEVELS(JLEV,LIST_NO) SETPLS1A.97
IF (LEVEL_NO.GE.1 .AND. LEVEL_NO.LE.N_LEVELS) THEN SETPLS1A.98
SETPLS1A.99
C Level is within range SETPLS1A.100
PSEUDO_LIST(LEVEL_NO) =.TRUE. SETPLS1A.101
SETPLS1A.102
ELSE SETPLS1A.103
SETPLS1A.104
C Level is out of range SETPLS1A.105
ICODE=2 SETPLS1A.106
CMESSAGE= ' SET_PSEUDO_LIST : level out of range' SETPLS1A.107
WRITE(6,*) ' SET_PSEUDO_LIST : level out of range' SETPLS1A.108
WRITE(6,*) ' pseudo list no = ',LIST_NO SB230293.1223
WRITE(6,*) ' level = ',LEVEL_NO SETPLS1A.109
WRITE(6,*) ' Section, Item = ',STLIST(2),STLIST(1) SETPLS1A.110
GO TO 999 ! Return SB230293.1224
SETPLS1A.111
END IF SETPLS1A.112
END DO SETPLS1A.113
SETPLS1A.114
END IF SETPLS1A.115
SETPLS1A.116
999 RETURN SETPLS1A.117
END SETPLS1A.118
*ENDIF SETPLS1A.119