*IF DEF,CONTROL CHKLKBA1.2
*IF DEF,ATMOS,AND,-DEF,GLOBAL GSH1F403.30
C ******************************COPYRIGHT****************************** GTS2F400.865
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.866
C GTS2F400.867
C Use, duplication or disclosure of this code is subject to the GTS2F400.868
C restrictions as set forth in the contract. GTS2F400.869
C GTS2F400.870
C Meteorological Office GTS2F400.871
C London Road GTS2F400.872
C BRACKNELL GTS2F400.873
C Berkshire UK GTS2F400.874
C RG12 2SZ GTS2F400.875
C GTS2F400.876
C If no contract has been raised with this copy of the code, the use, GTS2F400.877
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.878
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.879
C Modelling at the above address. GTS2F400.880
C ******************************COPYRIGHT****************************** GTS2F400.881
C GTS2F400.882
CLL SUBROUTINE CHK_LOOK_BOUNDA-------------------------------- CHKLKBA1.4
CLL CHKLKBA1.5
CLL Purpose: Cross checks values in LOOKUP records of boundary data CHKLKBA1.6
CLL with model run values CHKLKBA1.7
CLL CHKLKBA1.8
CLL Written by C. Wilson CHKLKBA1.9
CLL CHKLKBA1.10
CLL Model Modification history from model version 3.0: CHKLKBA1.11
CLL version Date CHKLKBA1.12
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.228
CLL portability. Author Tracey Smith. TS150793.229
CLL 3.2 26/05/93 Dynamic allocation changes. R.T.H.Barnes @DYALLOC.708
! 4.1 16/01/96 MPP code additions P.Burton APB4F401.83
! 4.1 18/06/96 Changes to cope with changes in STASH addressing GDG0F401.84
! Author D.M. Goddard. GDG0F401.85
!LL 4.4 04/08/97 Generalise for mixed phase precipitation scheme. ARB1F404.73
!LL ITEM_BOUNDA passed in from IN_BOUND. RTHBarnes. ARB1F404.74
CLL CHKLKBA1.13
CLL Programming standard: Unified Model Documentation Paper No 3 CHKLKBA1.14
CLL Version No 1 15/1/90 CHKLKBA1.15
CLL CHKLKBA1.16
CLL Logical components covered: C720 (part) CHKLKBA1.17
CLL CHKLKBA1.18
CLL Project task: C72 (part) CHKLKBA1.19
CLL CHKLKBA1.20
CLL Documentation: Unified Model Documentation Paper No C7 CHKLKBA1.21
CLL Version No 11 12/09/91 CHKLKBA1.22
CLL CHKLKBA1.23
CLLEND--------------------------------------------------------- CHKLKBA1.24
C*L Arguments:------------------------------------------------- CHKLKBA1.25
SUBROUTINE CHK_LOOK_BOUNDA(ITEM_BOUNDA,RIM_LOOKUPSA_DA, 1,13ARB1F404.75
*CALL ARGSIZE 
@DYALLOC.709
*CALL ARGBND @DYALLOC.710
*CALL ARGPPX GDG0F401.86
* ICODE,CMESSAGE) CHKLKBA1.27
CHKLKBA1.28
IMPLICIT NONE CHKLKBA1.29
@DYALLOC.711
*CALL CMAXSIZE @DYALLOC.712
*CALL TYPSIZE @DYALLOC.713
*CALL TYPBND @DYALLOC.714
*CALL CSUBMODL GDG0F401.87
*CALL CPPXREF GDG0F401.88
*CALL PPXLOOK GDG0F401.89
CHKLKBA1.30
INTEGER CHKLKBA1.31
& RIM_LOOKUPSA_DA, !IN length of ITEM_BOUNDA ARB1F404.76
& ITEM_BOUNDA(RIM_LOOKUPSA_DA), !IN STASH codes of update vars. ARB1F404.77
* ICODE !OUT Return code; successful=0 CHKLKBA1.32
* ! error > 0 CHKLKBA1.33
CHKLKBA1.34
CHARACTER *(80) TS150793.230
* CMESSAGE !OUT Error message if ICODE > 0 CHKLKBA1.36
CHKLKBA1.37
*CALL CLOOKADD CHKLKBA1.41
@DYALLOC.715
C ------------------------------------------------------------- CHKLKBA1.44
C Workspace usage:--------------------------------------------- CHKLKBA1.45
C None CHKLKBA1.46
C ------------------------------------------------------------- CHKLKBA1.47
C*L External subroutines called:------------------------------- CHKLKBA1.48
EXTERNAL PR_LOOK CHKLKBA1.49
C-------------------------------------------------------------- CHKLKBA1.50
C Local variables:--------------------------------------------- CHKLKBA1.51
INTEGER CHKLKBA1.52
* VAR ! Loop count for variable CHKLKBA1.53
*,CODE ! ITEM_CODE for variable CHKLKBA1.54
*,EXPVAL ! expected value in lookup CHKLKBA1.55
&, RIMLENA ! copy of LENRIMA or global_LENRIMA APB4F401.84
C-------------------------------------------------------------- CHKLKBA1.56
CHKLKBA1.57
CL Internal structure: None CHKLKBA1.58
CHKLKBA1.59
ICODE=0 CHKLKBA1.60
CMESSAGE=' ' CHKLKBA1.61
*IF DEF,MPP APB4F401.85
! Use size of global LBCs to compare against file values APB4F401.86
RIMLENA=global_LENRIMA APB4F401.87
*ELSE APB4F401.88
RIMLENA=LENRIMA APB4F401.89
*ENDIF APB4F401.90
CHKLKBA1.62
CL First check for expected number of variables for each time. ARB1F404.78
C I.e. that Item_code for variable 1 and RIM_LOOKUPSA+1 are the same. ARB1F404.79
IF (LOOKUP_BOUNDA(ITEM_CODE,1).ne. ARB1F404.80
& LOOKUP_BOUNDA(ITEM_CODE,RIM_LOOKUPSA+1)) THEN ARB1F404.81
! Print message for special case suggesting use of L_LSPICE_BDY=false ARB1F404.82
IF (ITEM_BOUNDA(RIM_LOOKUPSA).eq.12 .and. ARB1F404.83
& LOOKUP_BOUNDA(ITEM_CODE,RIM_LOOKUPSA).eq.1) THEN ARB1F404.84
WRITE(6,*)' **********************************************' ARB1F404.85
WRITE(6,*)' Boundary data does not have ice cloud present' ARB1F404.86
WRITE(6,*)' - try rerunning with L_LSPICE_BDY=.FALSE.' ARB1F404.87
WRITE(6,*)' - see umui window atmos_InFiles_OtherAncil_LBC' ARB1F404.88
WRITE(6,*)' **********************************************' ARB1F404.89
ELSE ARB1F404.90
WRITE(6,*)' CHK_LOOK_BOUNDA; wrong no.of variables for each time' ARB1F404.91
WRITE(6,*)' Expecting STASH item ',LOOKUP_BOUNDA(ITEM_CODE,1), ARB1F404.92
&' but found item ',LOOKUP_BOUNDA(ITEM_CODE,RIM_LOOKUPSA+1) ARB1F404.93
WRITE(6,*)' Lateral Boundary Conditions file is inconsistent with ARB1F404.94
&contents of Start Dump' ARB1F404.95
END IF ARB1F404.96
ICODE=1 ARB1F404.97
CMESSAGE='CHKLKBA : Item_Code Consistency check' ARB1F404.98
RETURN ARB1F404.99
END IF ARB1F404.100
CHKLKBA1.64
CL Now check header for each required variable ARB1F404.101
ARB1F404.102
DO 20 VAR=1,RIM_LOOKUPSA CHKLKBA1.65
CHKLKBA1.66
C Set STASHCODE for variable required for interfacing CHKLKBA1.67
CHKLKBA1.68
CODE=ITEM_BOUNDA(VAR) CHKLKBA1.69
CHKLKBA1.70
CL Check Item_code CHKLKBA1.71
IF(LOOKUP_BOUNDA(ITEM_CODE,VAR).NE.CODE) THEN CHKLKBA1.72
WRITE(6,101) LOOKUP_BOUNDA(ITEM_CODE,VAR),VAR ARB1F404.103
101 FORMAT(' *ERROR* Wrong value of',I9,' in LOOKUP_BOUNDA(ITEM_', CHKLKBA1.74
& 'CODE,',I4,')') CHKLKBA1.75
WRITE(6,*)' Expected value=',CODE GIE0F403.104
CHKLKBA1.77
CALL PR_LOOK( GDG0F401.90
*CALL ARGPPX GDG0F401.91
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.92
ICODE=1 CHKLKBA1.79
CMESSAGE='CHKLKBA : Item_Code Consistency check' CHKLKBA1.80
IF (CODE.eq.12 .and. LOOKUP_BOUNDA(ITEM_CODE,VAR).eq.1) THEN ARB1F404.104
WRITE(6,*)' **********************************************' ARB1F404.105
WRITE(6,*)' Boundary data does not have ice cloud present' ARB1F404.106
WRITE(6,*)' - try rerunning with L_LSPICE_BDY=.FALSE.' ARB1F404.107
WRITE(6,*)' - see umui window atmos_InFiles_OtherAncil_LBC' ARB1F404.108
WRITE(6,*)' **********************************************' ARB1F404.109
END IF ARB1F404.110
RETURN CHKLKBA1.81
ENDIF CHKLKBA1.82
CHKLKBA1.83
CL Check Length CHKLKBA1.84
IF(VAR.EQ.1.AND. CHKLKBA1.85
& LOOKUP_BOUNDA(LBLREC,VAR).NE.RIMLENA) THEN APB4F401.91
WRITE(6,102) LOOKUP_BOUNDA(LBLREC,VAR),VAR ARB1F404.111
102 FORMAT(' *ERROR* Wrong value of',I9,' in LOOKUP_BOUNDA(LBLREC', CHKLKBA1.88
& ',',I4,')') CHKLKBA1.89
WRITE(6,*)' Expected value=',RIMLENA,' for Pstar variable' ARB1F404.112
CALL PR_LOOK( GDG0F401.93
*CALL ARGPPX GDG0F401.94
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.95
ICODE=2 CHKLKBA1.92
CHKLKBA1.93
ELSE IF((VAR.EQ.2.OR.VAR.EQ.3).AND. CHKLKBA1.94
& LOOKUP_BOUNDA(LBLREC,VAR).NE.(RIMLENA-4*RIMWIDTHA)*P_LEVELS) APB4F401.93
& THEN CHKLKBA1.96
WRITE(6,102) LOOKUP_BOUNDA(LBLREC,VAR),VAR ARB1F404.113
EXPVAL= (RIMLENA-4*RIMWIDTHA)*P_LEVELS APB4F401.94
WRITE(6,*)' Expected value=',EXPVAL,' for wind variables' ARB1F404.114
CALL PR_LOOK( GDG0F401.96
*CALL ARGPPX GDG0F401.97
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.98
ICODE=2 CHKLKBA1.101
CHKLKBA1.102
ELSE IF(VAR.EQ.4.AND. CHKLKBA1.103
& LOOKUP_BOUNDA(LBLREC,VAR).NE.RIMLENA*P_LEVELS) THEN APB4F401.95
WRITE(6,102) LOOKUP_BOUNDA(LBLREC,VAR),VAR ARB1F404.115
EXPVAL= RIMLENA*P_LEVELS APB4F401.96
WRITE(6,*)' Expected value=',EXPVAL,' for thetal variable' ARB1F404.116
CALL PR_LOOK( GDG0F401.99
*CALL ARGPPX GDG0F401.100
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.101
ICODE=2 CHKLKBA1.109
CHKLKBA1.110
ELSE IF(VAR.EQ.5.AND. CHKLKBA1.111
& LOOKUP_BOUNDA(LBLREC,VAR).NE.RIMLENA*Q_LEVELS) THEN APB4F401.97
WRITE(6,102) LOOKUP_BOUNDA(LBLREC,VAR),VAR ARB1F404.117
EXPVAL= RIMLENA*Q_LEVELS APB4F401.98
WRITE(6,*)' Expected value=',EXPVAL,' for qt variable' ARB1F404.118
CALL PR_LOOK( GDG0F401.102
*CALL ARGPPX GDG0F401.103
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.104
ICODE=2 CHKLKBA1.117
CHKLKBA1.118
ELSE IF(VAR.GT.5 .AND. CODE.gt.60 .AND. ARB1F404.119
& LOOKUP_BOUNDA(LBLREC,VAR).NE.RIMLENA*TR_LEVELS) THEN APB4F401.99
WRITE(6,102) LOOKUP_BOUNDA(LBLREC,VAR),VAR ARB1F404.120
EXPVAL= RIMLENA*TR_LEVELS APB4F401.100
WRITE(6,*)' Expected value=',EXPVAL,' for tracer variables' ARB1F404.121
CALL PR_LOOK( GDG0F401.105
*CALL ARGPPX GDG0F401.106
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.107
ICODE=2 CHKLKBA1.125
CHKLKBA1.126
ELSE IF(VAR.GT.5 .AND. CODE.eq.12 .AND. ARB1F404.122
& LOOKUP_BOUNDA(LBLREC,VAR).NE.RIMLENA*Q_LEVELS) THEN ARB1F404.123
WRITE(6,102) LOOKUP_BOUNDA(LBLREC,VAR),VAR ARB1F404.124
EXPVAL= RIMLENA*TR_LEVELS ARB1F404.125
WRITE(6,*)' Expected value=',EXPVAL,' for qcf variable' ARB1F404.126
CALL PR_LOOK( ARB1F404.127
*CALL ARGPPX ARB1F404.128
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) ARB1F404.129
ICODE=2 ARB1F404.130
ARB1F404.131
END IF CHKLKBA1.127
IF(ICODE.EQ.2) THEN CHKLKBA1.128
CMESSAGE='CHKLKBA : Length Consistency check' CHKLKBA1.129
RETURN CHKLKBA1.130
END IF CHKLKBA1.131
CHKLKBA1.132
CL Check LBCODE CHKLKBA1.133
IF(VAR.EQ.2.OR.VAR.EQ.3) THEN CHKLKBA1.134
IF(LOOKUP_BOUNDA(LBCODE,VAR).NE.2) THEN CHKLKBA1.135
CHKLKBA1.136
WRITE(6,103) LOOKUP_BOUNDA(LBCODE,VAR),VAR ARB1F404.132
103 FORMAT(' *ERROR* Wrong value of',I9,' in LOOKUP_BOUNDA(LBCODE', CHKLKBA1.138
& ',',I4,')') CHKLKBA1.139
WRITE(6,*)' Expected value=2' GIE0F403.110
CALL PR_LOOK( GDG0F401.108
*CALL ARGPPX GDG0F401.109
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.110
ICODE=3 CHKLKBA1.142
CMESSAGE='CHKLKBA : LBCODE Consistency check' CHKLKBA1.143
RETURN CHKLKBA1.144
ENDIF CHKLKBA1.145
ELSE IF(LOOKUP_BOUNDA(LBCODE,VAR).NE.1) THEN CHKLKBA1.146
WRITE(6,103) LOOKUP_BOUNDA(LBCODE,VAR),VAR ARB1F404.133
WRITE(6,*)' Expected value=1' GIE0F403.111
CALL PR_LOOK( GDG0F401.111
*CALL ARGPPX GDG0F401.112
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.113
ICODE=3 CHKLKBA1.150
CMESSAGE='CHKLKBA : LBCODE Consistency check' CHKLKBA1.151
RETURN CHKLKBA1.152
END IF CHKLKBA1.153
CHKLKBA1.154
CL Check boundary rim indicator CHKLKBA1.155
IF(LOOKUP_BOUNDA(LBHEM,VAR).NE.99) THEN CHKLKBA1.156
WRITE(6,104) LOOKUP_BOUNDA(LBHEM,VAR),VAR ARB1F404.134
104 FORMAT(' *ERROR* Wrong value of',I9,' in LOOKUP_BOUNDA(LBHEM', CHKLKBA1.158
& ',',I4,')') CHKLKBA1.159
WRITE(6,*)' Expected value=99' GIE0F403.112
CALL PR_LOOK( GDG0F401.114
*CALL ARGPPX GDG0F401.115
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.116
ICODE=4 CHKLKBA1.162
CMESSAGE='CHKLKBA : LBHEM Consistency check' CHKLKBA1.163
RETURN CHKLKBA1.164
END IF CHKLKBA1.165
CHKLKBA1.166
CL Check LBROW CHKLKBA1.167
IF(LOOKUP_BOUNDA(LBROW,VAR).NE.RIMWIDTHA) THEN CHKLKBA1.168
WRITE(6,105) LOOKUP_BOUNDA(LBROW,VAR),VAR ARB1F404.135
105 FORMAT(' *ERROR* Wrong value of',I9,' in LOOKUP_BOUNDA(LBROW', CHKLKBA1.170
& ',',I4,')') CHKLKBA1.171
WRITE(6,*)' Expected value=',RIMWIDTHA GIE0F403.113
CALL PR_LOOK( GDG0F401.117
*CALL ARGPPX GDG0F401.118
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.119
ICODE=5 CHKLKBA1.174
CMESSAGE='CHKLKBA : LBROW Consistency check' CHKLKBA1.175
RETURN CHKLKBA1.176
END IF CHKLKBA1.177
CHKLKBA1.178
CL Check LBNPT CHKLKBA1.179
IF(VAR.EQ.2.OR.VAR.EQ.3) THEN CHKLKBA1.180
IF(LOOKUP_BOUNDA(LBNPT,VAR).NE. CHKLKBA1.181
& ((RIMLENA-4*RIMWIDTHA)/RIMWIDTHA)) THEN APB4F401.101
WRITE(6,106) LOOKUP_BOUNDA(LBNPT,VAR),VAR ARB1F404.136
106 FORMAT(' *ERROR* Wrong value of',I9,' in LOOKUP_BOUNDA(LBNPT', CHKLKBA1.184
& ',',I4,')') CHKLKBA1.185
EXPVAL= (RIMLENA-4*RIMWIDTHA)/RIMWIDTHA APB4F401.102
WRITE(6,*)' Expected value=',EXPVAL GIE0F403.114
CALL PR_LOOK( GDG0F401.120
*CALL ARGPPX GDG0F401.121
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.122
ICODE=6 CHKLKBA1.189
CMESSAGE='CHKLKBA : LBNPT Consistency check' CHKLKBA1.190
RETURN CHKLKBA1.191
ENDIF CHKLKBA1.192
ELSEIF(LOOKUP_BOUNDA(LBNPT,VAR).NE.RIMLENA/RIMWIDTHA) THEN APB4F401.103
WRITE(6,106) LOOKUP_BOUNDA(LBNPT,VAR),VAR ARB1F404.137
EXPVAL= RIMLENA/RIMWIDTHA APB4F401.104
WRITE(6,*)' Expected value=',EXPVAL GIE0F403.115
CALL PR_LOOK( GDG0F401.123
*CALL ARGPPX GDG0F401.124
& LOOKUP_BOUNDA,LOOKUP_BOUNDA,LEN1_LOOKUP,VAR) GDG0F401.125
ICODE=6 CHKLKBA1.198
CMESSAGE='CHKLKBA : LBNPT Consistency check' CHKLKBA1.199
RETURN CHKLKBA1.200
END IF CHKLKBA1.201
CHKLKBA1.202
20 CONTINUE CHKLKBA1.203
CHKLKBA1.204
CHKLKBA1.205
RETURN CHKLKBA1.206
END CHKLKBA1.207
*ENDIF CHKLKBA1.208
*ENDIF CHKLKBA1.209