*IF DEF,A18_1A,OR,DEF,A18_2A,OR,DEF,RECON VSB1F304.155
C ******************************COPYRIGHT****************************** GTS2F400.9775
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.9776
C GTS2F400.9777
C Use, duplication or disclosure of this code is subject to the GTS2F400.9778
C restrictions as set forth in the contract. GTS2F400.9779
C GTS2F400.9780
C Meteorological Office GTS2F400.9781
C London Road GTS2F400.9782
C BRACKNELL GTS2F400.9783
C Berkshire UK GTS2F400.9784
C RG12 2SZ GTS2F400.9785
C GTS2F400.9786
C If no contract has been raised with this copy of the code, the use, GTS2F400.9787
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.9788
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.9789
C Modelling at the above address. GTS2F400.9790
C ******************************COPYRIGHT****************************** GTS2F400.9791
C GTS2F400.9792
CLL Subroutine STRATQ STRATQ1A.3
CLL STRATQ1A.4
CLL Purpose : To reset the moisture levels in the stratosphere STRATQ1A.5
CLL to climatological values STRATQ1A.6
CLL (min q=1.E-6,max q=3.E-6 or max RH=10%) STRATQ1A.7
CLL called in assimilation mode at model_analysis_hour STRATQ1A.8
CLL and at end of assimilation period STRATQ1A.9
CLL STRATQ1A.10
CLL For CRAY YMP STRATQ1A.11
CLL STRATQ1A.12
CLL S.Bell <- programmer of some or all of previous code or changes STRATQ1A.13
CLL STRATQ1A.14
CLL Model Modification history from model version 3.0: STRATQ1A.15
CLL version Date STRATQ1A.16
CLL 3.2 19/04/93 Code for new real missing data indicator (TCJ). TJ050593.120
CLL 3.2 8/7/93 Eliminate QA FORTRAN complaints S Bell SB100793.490
CLL 3.4 7/9/94 Eliminate cloud water/ice and RHCRIT ABM1F304.220
CLL from arg list and calls to HMRTORH Bruce M ABM1F304.221
CLL 3.4 19/9/94 Make available for A18_2A S Bell VSB1F304.156
!+ VSB1F304.157
CLL STRATQ1A.17
CLL Programming standard; Unified Model Documentation Paper No. 4 STRATQ1A.18
CLL version no. 3, dated 15/08/90 STRATQ1A.19
CLL STRATQ1A.20
CLL System components covered : P3 STRATQ1A.21
CLL STRATQ1A.22
CLL Documentation : STRATQ1A.23
CLL STRATQ1A.24
CLLEND STRATQ1A.25
STRATQ1A.26
C*L ARGUMENTS:--------------------------------------------------- STRATQ1A.27
SUBROUTINE STRATQ( 2,4STRATQ1A.28
C primary data in STRATQ1A.29
& PSTAR,Q,THETA,OROG,P_EXNER_HALF, ABM1F304.222
C primary data constants STRATQ1A.31
& P_LEVELS,Q_LEVELS,P_FIELD, STRATQ1A.32
& AK,BK,AKH,BKH, STRATQ1A.33
& MIN_TROP_LEV, STRATQ1A.35
C return code and message. STRATQ1A.36
& ICODE,CMESSAGE) STRATQ1A.37
C*--------------------------------------------------------------------- STRATQ1A.38
STRATQ1A.39
IMPLICIT NONE STRATQ1A.40
STRATQ1A.41
*CALL C_G 
STRATQ1A.42
STRATQ1A.43
C*L-------------------------------------------------------------------- STRATQ1A.44
INTEGER STRATQ1A.45
* P_FIELD !IN 1ST DIMENSION OF FIELD OF PSTAR STRATQ1A.46
*, P_LEVELS !IN NUMBER OF MODEL LEVELS STRATQ1A.47
*, Q_LEVELS !IN NUMBER OF WET LEVELS STRATQ1A.48
*, ICODE ! RETURN CODE : ICODE=0 NORMAL EXIT STRATQ1A.49
*, MIN_TROP_LEV !IN MIN LEVEL OF TROPOPAUSE STRATQ1A.50
STRATQ1A.51
CHARACTER STRATQ1A.52
* CMESSAGE*(*) STRATQ1A.53
STRATQ1A.54
REAL STRATQ1A.55
* PSTAR(P_FIELD) !IN PRIMARY MODEL ARRAY FOR PSTAR FIELD STRATQ1A.56
*,OROG(P_FIELD) !IN PRIMARY MODEL OROGRAPHY STRATQ1A.57
*,P_EXNER_HALF(P_FIELD,P_LEVELS+1) !IN EXNER PRESS ON 1/2 LVLS STRATQ1A.58
*,THETA(P_FIELD,P_LEVELS) !IN PRIMARY MODEL ARRAY FOR THETA FIELD STRATQ1A.59
*,Q(P_FIELD,Q_LEVELS) !IN PRIMARY MODEL ARRAY FOR HUMIDITY STRATQ1A.60
*,AK (P_LEVELS) !IN } hybrid coords (A and B values) STRATQ1A.63
*,BK (P_LEVELS) !IN } for full model levels STRATQ1A.64
*,AKH(P_LEVELS+1) !IN } hybrid coords (A and B values) STRATQ1A.65
*,BKH(P_LEVELS+1) !IN } for half model levels STRATQ1A.66
C*--------------------------------------------------------------------- STRATQ1A.68
STRATQ1A.69
C*L WORKSPACE USAGE:------------------------------------------------- STRATQ1A.70
REAL STRATQ1A.71
* TROP_T(P_FIELD) ! OUTPUT TEMPS OF TROPOPAUSE STRATQ1A.72
*,TROP_P(P_FIELD) ! OUTPUT PRESSURE OF TROPOPAUSE STRATQ1A.73
*,TROP_Z(P_FIELD) ! OUTPUT HEIGHT OF TROPOPAUSE PRESSURE SURFACE STRATQ1A.74
*,MODEL_HALF_HEIGHT(P_FIELD,P_LEVELS+1) !OUT HEIGHTS OF MODEL HALF STRATQ1A.75
*, PHI_STAR(P_FIELD) ! Geopotential STRATQ1A.76
C*--------------------------------------------------------------------- STRATQ1A.77
STRATQ1A.78
C*L EXTERNAL SUBROUTINES CALLED--------------------------------------- STRATQ1A.79
EXTERNAL V_INT_ZH,TROP,HMRTORH STRATQ1A.80
C*--------------------------------------------------------------------- STRATQ1A.81
STRATQ1A.82
C DEFINE LOCAL VARIABLES STRATQ1A.83
INTEGER K,I ! LOOP COUNTERS IN ROUTINE STRATQ1A.84
REAL MAXSTQ ! MAX ALLOWED STRATO MIXING RATIO STRATQ1A.85
REAL MAXSTRH ! MAX ALLOWED STRATO RELATIVE HUMIDITY STRATQ1A.86
REAL MINSTQ ! MIN ALLOWED STRATO MIXING RATIO STRATQ1A.87
REAL MINTROP ! MIN ALLOWED TROP PRESSURE STRATQ1A.88
REAL PHERE ! pressure at a model level STRATQ1A.89
REAL TROP_MAX,TROP_MIN ! diagnostic info - range of TROP_P STRATQ1A.90
PARAMETER (MAXSTQ=3.E-6,MAXSTRH=10.,MINTROP=10000.) STRATQ1A.91
PARAMETER (MINSTQ=1.E-6) STRATQ1A.92
STRATQ1A.93
ICODE=0 STRATQ1A.94
CMESSAGE=' ' STRATQ1A.95
STRATQ1A.96
CL--------- Get MODEL_HALF_HEIGHTS STRATQ1A.97
CL-------------------------------- STRATQ1A.98
DO 100 I=1,P_FIELD STRATQ1A.99
PHI_STAR(I)=OROG(I)*G STRATQ1A.100
100 CONTINUE STRATQ1A.101
CALL V_INT_ZH(P_EXNER_HALF,THETA,Q,PHI_STAR, STRATQ1A.102
* MODEL_HALF_HEIGHT,P_FIELD,P_LEVELS,Q_LEVELS) STRATQ1A.103
STRATQ1A.104
CL--------- Get tropopause pressure TROP_P STRATQ1A.105
CL---------------------------------------- STRATQ1A.106
CALL TROP(PSTAR,THETA,P_EXNER_HALF,MODEL_HALF_HEIGHT,TROP_T, STRATQ1A.107
& TROP_P,TROP_Z,P_FIELD,P_LEVELS,MIN_TROP_LEV,AKH,BKH) STRATQ1A.108
STRATQ1A.109
CL--------- Diagnostic print of TROP_P range STRATQ1A.110
CL------------------------------------------ STRATQ1A.111
TROP_MAX=TROP_P(1) STRATQ1A.112
DO 200 I=2,P_FIELD STRATQ1A.113
IF(TROP_P(I).GT.TROP_MAX)THEN STRATQ1A.114
TROP_MAX=TROP_P(I) STRATQ1A.115
ENDIF STRATQ1A.116
200 CONTINUE STRATQ1A.117
STRATQ1A.118
TROP_MIN=TROP_P(1) STRATQ1A.119
DO 210 I=2,P_FIELD STRATQ1A.120
IF(TROP_P(I).LT.TROP_MIN)THEN STRATQ1A.121
TROP_MIN=TROP_P(I) STRATQ1A.122
ENDIF STRATQ1A.123
210 CONTINUE STRATQ1A.124
STRATQ1A.125
TROP_MAX=TROP_MAX*.01 STRATQ1A.126
TROP_MIN=TROP_MIN*.01 STRATQ1A.127
WRITE(6,*)' STRATQ diagnostics---TROPOPAUSE range is ', STRATQ1A.128
* TROP_MAX,'mb to ',TROP_MIN,'mb' STRATQ1A.129
STRATQ1A.130
CL--------- Reset TROP_P if less than MINTROP STRATQ1A.131
CL------------------------------------------- STRATQ1A.132
C (TROP routine currently returns RMDI(-2**30) if no tropopause found!) TJ050593.121
DO 300 I=1,P_FIELD STRATQ1A.134
IF(TROP_P(I).LT.MINTROP)THEN STRATQ1A.135
TROP_P(I)=MINTROP STRATQ1A.136
ENDIF STRATQ1A.137
300 CONTINUE STRATQ1A.138
STRATQ1A.139
TROP_MIN=MINTROP*.01 STRATQ1A.140
WRITE(6,*)' Minimum tropopause pressure reset to ', STRATQ1A.141
* TROP_MIN,'mb' STRATQ1A.142
STRATQ1A.143
CL--------- Reset Q above TROP_P (must be less than MAXSTQ) STRATQ1A.144
CL--------------------------------------------------------- STRATQ1A.145
DO 400 K=MIN_TROP_LEV,Q_LEVELS STRATQ1A.146
DO 410 I=1, P_FIELD STRATQ1A.147
PHERE = AK(K) + BK(K)*PSTAR(I) STRATQ1A.148
IF ( PHERE .LT. TROP_P(I)) THEN STRATQ1A.149
Q(I,K) = MIN ( Q(I,K), MAXSTQ ) STRATQ1A.150
Q(I,K) = MAX ( Q(I,K), MINSTQ ) STRATQ1A.151
ENDIF STRATQ1A.152
410 CONTINUE STRATQ1A.153
400 CONTINUE STRATQ1A.154
STRATQ1A.155
CL--------- Convert Q to RH STRATQ1A.156
CL------------------------- STRATQ1A.157
CALL HMRTORH (1,AK,BK,P_EXNER_HALF, STRATQ1A.158
* PSTAR,THETA,Q, STRATQ1A.159
* P_FIELD,P_LEVELS,Q_LEVELS, STRATQ1A.161
* AKH,BKH,ICODE,CMESSAGE) STRATQ1A.162
IF(ICODE.GT.0)GOTO 999 STRATQ1A.163
STRATQ1A.164
CL--------- Reset RH above TROP_P (must be less than MAXSTRH) STRATQ1A.165
CL--------------------------------------------------------- STRATQ1A.166
DO 500 K=MIN_TROP_LEV,Q_LEVELS STRATQ1A.167
DO 510 I=1, P_FIELD STRATQ1A.168
PHERE = AK(K) + BK(K)*PSTAR(I) STRATQ1A.169
IF ( PHERE .LT. TROP_P(I)) THEN STRATQ1A.170
Q(I,K) = MIN ( Q(I,K), MAXSTRH) STRATQ1A.171
ENDIF STRATQ1A.172
510 CONTINUE STRATQ1A.173
500 CONTINUE STRATQ1A.174
STRATQ1A.175
CL----------Convert Q back to mixing ratio STRATQ1A.176
CL---------------------------------------- STRATQ1A.177
CALL HMRTORH (2,AK,BK,P_EXNER_HALF, STRATQ1A.178
* PSTAR,THETA,Q, STRATQ1A.179
* P_FIELD,P_LEVELS,Q_LEVELS, STRATQ1A.181
* AKH,BKH,ICODE,CMESSAGE) STRATQ1A.182
IF(ICODE.GT.0)GOTO 999 STRATQ1A.183
STRATQ1A.184
ICODE=0 STRATQ1A.185
CMESSAGE=' ' STRATQ1A.186
STRATQ1A.187
999 CONTINUE SB100793.491
RETURN SB100793.492
END STRATQ1A.189
*ENDIF STRATQ1A.190