*IF DEF,A10_1A,OR,DEF,A10_1B,OR,DEF,A10_1C AAD2F404.247
*IF -DEF,SCMA AJC0F405.286
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13008
C GTS2F400.13009
C Use, duplication or disclosure of this code is subject to the GTS2F400.13010
C restrictions as set forth in the contract. GTS2F400.13011
C GTS2F400.13012
C Meteorological Office GTS2F400.13013
C London Road GTS2F400.13014
C BRACKNELL GTS2F400.13015
C Berkshire UK GTS2F400.13016
C RG12 2SZ GTS2F400.13017
C GTS2F400.13018
C If no contract has been raised with this copy of the code, the use, GTS2F400.13019
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13020
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13021
C Modelling at the above address. GTS2F400.13022
C ******************************COPYRIGHT****************************** GTS2F400.13023
C GTS2F400.13024
CLL SUBROUTINE DIAG10_QC-------------------------------------------- DIA10Q1A.3
CLL DIA10Q1A.4
CLL PURPOSE: Process diagnostics on qcl/qcf before dynamics DIA10Q1A.5
CLL DIA10Q1A.6
CLL B Macpherson<- programmer of some or all of previous code or changes DIA10Q1A.7
CLL DIA10Q1A.8
CLL Model Modification history from model version 3.0: DIA10Q1A.9
CLL version Date DIA10Q1A.10
CLL DIA10Q1A.11
CLL 4.0 1/9/95 New deck based on DIA10A1A DIA10Q1A.12
!LL 4.3 11/02/97 Added ARGFLDPT and ARGPPX arguments P.Burton GPB1F403.1179
!LL 4.5 28/10/98 Introduce Single Column Model. J-C Thil. AJC0F405.287
CLL DIA10Q1A.13
CLL Programming standard: U M DOC Paper NO. 4, DIA10Q1A.14
CLL DIA10Q1A.15
CLL Logical components covered : DIA10Q1A.16
CLL DIA10Q1A.17
CLL Project task: P1 DIA10Q1A.18
CLL DIA10Q1A.19
CLL External documentation: DIA10Q1A.20
CLL DIA10Q1A.21
CLLEND--------------------------------------------------------------- DIA10Q1A.22
DIA10Q1A.23
C*L ARGUMENTS:------------------------------------------------------ DIA10Q1A.24
DIA10Q1A.25
SUBROUTINE DIAG10_QC(QCL,QCF, 1,2DIA10Q1A.26
& ROW_LENGTH,P_LEVELS,Q_LEVELS,P_FIELD, DIA10Q1A.27
& NSECTS,NITEMS,TOTITEMS,NUM_STASH_LEVELS, DIA10Q1A.28
& NUM_LEVEL_LISTS,LEN_STLIST,STASHLEN,SF, DIA10Q1A.29
& STINDEX,STLIST,SI,STASH_LEVELS,STASHWORK, DIA10Q1A.30
& im_ident, GPB1F403.1180
*CALL ARGFLDPT 
GPB1F403.1181
*CALL ARGPPX GPB1F403.1182
& ICODE,CMESSAGE) DIA10Q1A.31
DIA10Q1A.32
IMPLICIT NONE DIA10Q1A.33
DIA10Q1A.34
INTEGER DIA10Q1A.35
& P_FIELD !IN 1ST DIMENSION OF FIELD OF PSTAR DIA10Q1A.36
&, ROW_LENGTH !IN NUMBER OF POINTS PER ROW DIA10Q1A.37
&, P_LEVELS !IN NUMBER OF PRESSURE LEVELS DIA10Q1A.38
&, Q_LEVELS !IN NUMBER OF WET LEVELS DIA10Q1A.39
DIA10Q1A.40
INTEGER GPB1F403.1183
& im_ident !IN : Internal model indent GPB1F403.1184
GPB1F403.1185
*CALL TYPFLDPT GPB1F403.1186
*CALL CSUBMODL GPB1F403.1187
*CALL CPPXREF GPB1F403.1188
*CALL PPXLOOK GPB1F403.1189
INTEGER DIA10Q1A.41
& ICODE !OUT RETURN CODE. NON-ZERO IF ERROR-DETECTED DIA10Q1A.42
DIA10Q1A.43
CHARACTER DIA10Q1A.44
& CMESSAGE*(*) !OUT ERROR MESSAGE DIA10Q1A.45
DIA10Q1A.46
C INPUT DATA DIA10Q1A.47
DIA10Q1A.48
REAL DIA10Q1A.49
& QCL (P_FIELD,Q_LEVELS) !IN PRIMARY MODEL ARRAY FOR QCL DIA10Q1A.50
&, QCF (P_FIELD,Q_LEVELS) !IN PRIMARY MODEL ARRAY FOR QCF DIA10Q1A.51
DIA10Q1A.52
C STASH REQUIREMENTS. DIA10Q1A.53
DIA10Q1A.54
INTEGER DIA10Q1A.55
& NSECTS !IN NO OF PROCESSING SECTIONS (MASTER PCRS) DIA10Q1A.56
&, NITEMS !IN MAX NO OF STASH ITEMS IN A SECTION DIA10Q1A.57
&, TOTITEMS !IN MAX NO OF TOTAL STASH ITEMS DIA10Q1A.58
&, NUM_STASH_LEVELS !IN MAX NUMBER OF LEVELS IN A LEVELS LIST DIA10Q1A.59
&, NUM_LEVEL_LISTS !IN MAX NUMBER OF LEVELS LIST DIA10Q1A.60
&, LEN_STLIST !IN LENGTH OF LIST OF ITEMS FROM STASH DIA10Q1A.61
&, STASHLEN !IN SIZE OF STASHWORK DIA10Q1A.62
DIA10Q1A.63
INTEGER DIA10Q1A.64
& STINDEX(2,NITEMS,0:NSECTS) !IN DIA10Q1A.65
&, STLIST(LEN_STLIST,TOTITEMS) !IN DIA10Q1A.66
&, SI(NITEMS,0:NSECTS) !IN DIA10Q1A.67
&, STASH_LEVELS(NUM_STASH_LEVELS+1,NUM_LEVEL_LISTS) !IN DIA10Q1A.68
DIA10Q1A.69
LOGICAL DIA10Q1A.70
& SF(0:NITEMS,0:NSECTS) !IN DIA10Q1A.71
DIA10Q1A.72
REAL DIA10Q1A.73
& STASHWORK(STASHLEN) !INOUT. WORK SPACE HOLDING STASH OUTPUT. DIA10Q1A.74
DIA10Q1A.75
C*-------------------------------------------------------------------- DIA10Q1A.76
DIA10Q1A.77
C*L DEFINE LOCAL VARIABLES USED IN THIS ROUTINE---------- DIA10Q1A.78
INTEGER DIA10Q1A.79
& FIRST_P ! first point for COPYDIAG for P grid DIA10Q1A.80
& ,LAST_P ! last point for COPYDIAG for P grid DIA10Q1A.81
DIA10Q1A.82
DIA10Q1A.83
C*-------------------------------------------------------------------- DIA10Q1A.84
DIA10Q1A.85
C*L EXTERNAL SUBROUTINES CALLED ------------------------------------ DIA10Q1A.86
EXTERNAL COPYDIAG_3D DIA10Q1A.87
C*-------------------------------------------------------------------- DIA10Q1A.88
DIA10Q1A.89
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD DIA10Q1A.90
DIA10Q1A.91
FIRST_P=FIRST_FLD_PT GPB1F403.1190
LAST_P=LAST_P_FLD_PT GPB1F403.1191
DIA10Q1A.94
CL SECTION 1 qcl DIA10Q1A.95
DIA10Q1A.96
IF ( SF(229,10) ) THEN DIA10Q1A.97
CALL COPYDIAG_3D (STASHWORK(SI(229,10)),QCL,FIRST_P, DIA10Q1A.98
& LAST_P,P_FIELD,ROW_LENGTH,Q_LEVELS, DIA10Q1A.99
& STLIST(1,STINDEX(1,229,10)),LEN_STLIST, DIA10Q1A.100
& STASH_LEVELS, DIA10Q1A.101
& NUM_STASH_LEVELS+1, GPB1F403.1192
& im_ident,10,229, GPB1F403.1193
*CALL ARGPPX GPB1F403.1194
& ICODE,CMESSAGE) GPB1F403.1195
IF(ICODE.GT.0) THEN DIA10Q1A.103
RETURN DIA10Q1A.104
END IF DIA10Q1A.105
END IF DIA10Q1A.106
DIA10Q1A.107
CL SECTION 2 qcf DIA10Q1A.108
DIA10Q1A.109
IF ( SF(230,10) ) THEN DIA10Q1A.110
CALL COPYDIAG_3D (STASHWORK(SI(230,10)),QCF,FIRST_P, DIA10Q1A.111
& LAST_P,P_FIELD,ROW_LENGTH,Q_LEVELS, DIA10Q1A.112
& STLIST(1,STINDEX(1,230,10)),LEN_STLIST, DIA10Q1A.113
& STASH_LEVELS, DIA10Q1A.114
& NUM_STASH_LEVELS+1, GPB1F403.1196
& im_ident,10,230, GPB1F403.1197
*CALL ARGPPX GPB1F403.1198
& ICODE,CMESSAGE) GPB1F403.1199
IF(ICODE.GT.0) THEN DIA10Q1A.116
RETURN DIA10Q1A.117
END IF DIA10Q1A.118
END IF DIA10Q1A.119
DIA10Q1A.120
RETURN DIA10Q1A.121
END DIA10Q1A.122
*ENDIF DIA10Q1A.123
*ENDIF AJC0F405.288