*IF DEF,A12_1B ARB2F400.7
C ******************************COPYRIGHT****************************** GTS2F400.7903
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.7904
C GTS2F400.7905
C Use, duplication or disclosure of this code is subject to the GTS2F400.7906
C restrictions as set forth in the contract. GTS2F400.7907
C GTS2F400.7908
C Meteorological Office GTS2F400.7909
C London Road GTS2F400.7910
C BRACKNELL GTS2F400.7911
C Berkshire UK GTS2F400.7912
C RG12 2SZ GTS2F400.7913
C GTS2F400.7914
C If no contract has been raised with this copy of the code, the use, GTS2F400.7915
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.7916
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.7917
C Modelling at the above address. GTS2F400.7918
C ******************************COPYRIGHT****************************** GTS2F400.7919
C GTS2F400.7920
CLL SUBROUTINE QT_ADV ------------------------------------------- QTADV1A.3
CLL QTADV1A.4
CLL PURPOSE: CALCULATES MASS-WEIGHTED INCREMENTS TO QT QTADV1A.5
CLL DUE TO ADVECTION BY USING EQUATION (36) QTADV1A.6
CLL TO CALCULATE PROVISIONAL VALUES OF QT AT QTADV1A.7
CLL THE NEW TIME-LEVEL, AND THEN RECALCULATING THE QTADV1A.8
CLL ADVECTION TERMS ON THE RIGHT-HAND SIDE OF (36) QTADV1A.9
CLL USING THESE PROVISIONAL VALUES. THE FINAL INCREMENTS ARE QTADV1A.10
CLL CALCULATED AS IN EQUATION (40). THOSE REQUIRING QTADV1A.11
CLL FILTERING ARE FILTERED, THE INCREMENTS QTADV1A.12
CLL ARE ADDED ONTO THE FIELDS USING (40). QTADV1A.13
CLL IF RUNNING A GLOBAL MODEL POLAR IS CALLED QTADV1A.14
CLL TO UPDATE POLAR VALUES. QTADV1A.15
CLL NOT SUITABLE FOR SINGLE COLUMN USE. QTADV1A.16
CLL VERSION FOR CRAY Y-MP QTADV1A.17
CLL QTADV1A.18
CLL WRITTEN BY M.H MAWSON. QTADV1A.19
CLL QTADV1A.20
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: QTADV1A.21
CLL VERSION DATE QTADV1A.22
CLL QTADV1A.23
CLL 3.4 06/08/94 Code restructured to improve parallel efficiency AAD2F304.126
CLL on C90. AAD2F304.127
CLL Authors: A. Dickinson, D. Salmond AAD2F304.128
CLL Reviewer: M. Mawson AAD2F304.129
CLL AAD2F304.130
CLL 3.4 22/06/94 Argument LWHITBROM added and passed to ADV_P_GD GSS1F304.886
CLL S.J.Swarbrick GSS1F304.887
! 3.5 28/03/95 MPP code: Change updateable area and APB0F305.764
! add boundary swaps. P.Burton APB0F305.765
CLL GSS1F304.888
CLL 4.0 14/02/95 Option to run with half_timestep at top level ATD1F400.955
CLL removed. Author: T Davies, Reviewer: M Mawson ATD1F400.956
! 4.1 29/04/96 Remove MPP code (new QTADV1C version for MPP) APB0F401.1103
! and add TYPFLDPT arguments P.Burton APB0F401.1104
!LL 4.2 16/08/96 Add TYPFLDPT arguments to FILTER subroutine APB0F402.15
!LL and make the FILTER_WAVE_NUMBER arrays APB0F402.16
!LL globally sized P.Burton APB0F402.17
!LL 4.2 30/10/96 Move declaration of TYPFLDPT variables to top of APB1F402.46
!LL declarations. P.Burton APB1F402.47
!LL 4.3 24/04/97 Fix to 4th order calculations - GPB5F403.3
!LL Calculation of NUY via ISMIN P.Burton GPB5F403.4
!LL 4.5 05/05/98 Recode -DEF,CRAY loops to find minimum of NUX/NUY GRB0F405.104
!LL to vectorize on Fujitsu VPP700. RBarnes@ecmwf.int GRB0F405.105
!LL 4.5 22/06/98 Fujitsu vectorization directives. R.Barnes. GRB0F405.106
!LL GRB0F405.107
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, QTADV1A.24
CLL STANDARD B. QTADV1A.25
CLL QTADV1A.26
CLL SYSTEM COMPONENTS COVERED: P121 QTADV1A.27
CLL QTADV1A.28
CLL SYSTEM TASK: P1 QTADV1A.29
CLL QTADV1A.30
CLL DOCUMENTATION: THE EQUATIONS USED ARE (36) AND (40) QTADV1A.31
CLL IN UNIFIED MODEL DOCUMENTATION PAPER NO. 10 QTADV1A.32
CLL M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON QTADV1A.33
CLLEND------------------------------------------------------------- QTADV1A.34
QTADV1A.35
C*L ARGUMENTS:--------------------------------------------------- QTADV1A.36
SUBROUTINE QT_ADV 1,33QTADV1A.37
1 (QT,PSTAR_OLD,PSTAR,U_MEAN,V_MEAN, QTADV1A.38
2 SEC_P_LATITUDE,ETADOT_MEAN,RS,DELTA_AK,DELTA_BK, QTADV1A.39
3 LATITUDE_STEP_INVERSE,ADVECTION_TIMESTEP,NU_BASIC, QTADV1A.40
4 LONGITUDE_STEP_INVERSE,NORTHERN_FILTERED_P_ROW, QTADV1A.41
5 SOUTHERN_FILTERED_P_ROW,Q_LEVELS,P_LEVELS, QTADV1A.42
6 U_FIELD,P_FIELD,ROW_LENGTH, APB0F401.1105
*CALL ARGFLDPT 
APB0F401.1106
6 TRIGS, APB0F401.1107
7 IFAX,FILTER_WAVE_NUMBER_P_ROWS,SEC_U_LATITUDE, QTADV1A.44
8 AKH,BKH,L_SECOND,LWHITBROM) ATD1F400.957
QTADV1A.46
IMPLICIT NONE QTADV1A.47
QTADV1A.48
! All TYPFLDPT arguments are intent IN APB1F402.48
*CALL TYPFLDPT APB1F402.49
INTEGER QTADV1A.49
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. QTADV1A.50
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID QTADV1A.51
*, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. QTADV1A.53
*, Q_LEVELS !IN NUMBER OF MOIST LEVELS. QTADV1A.54
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW QTADV1A.56
*, NORTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STOPS QTADV1A.57
* ! MOVING TOWARDS EQUATOR QTADV1A.58
*, SOUTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STARTS AGAIN QTADV1A.59
* ! MOVING TOWARDS SOUTH POLE QTADV1A.60
&, FILTER_WAVE_NUMBER_P_ROWS(GLOBAL_P_FIELD/GLOBAL_ROW_LENGTH) APB0F402.18
& ! LAST WAVE NUMBER NOT TO BE CHOPPED APB0F402.19
*, IFAX(10) !IN HOLDS FACTORS OF ROW_LENGTH USED BY QTADV1A.63
* ! FILTERING. QTADV1A.64
APB0F401.1108
QTADV1A.65
C LOGICAL VARIABLE QTADV1A.66
LOGICAL QTADV1A.67
* L_SECOND ! SET TO TRUE IF NU_BASIC IS ZERO. QTADV1A.68
& ,LWHITBROM ! LOGICAL SWITCH FOR WHITE & BROMLEY GSS1F304.890
QTADV1A.71
REAL QTADV1A.72
* U_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED U VELOCITY QTADV1A.73
* ! FROM ADJUSTMENT STEP QTADV1A.74
*,V_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED V VELOCITY QTADV1A.75
* ! * COS(LAT) FROM ADJUSTMENT STEP QTADV1A.76
*,ETADOT_MEAN(P_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED QTADV1A.77
* !VERTICAL VELOCITY FROM ADJUSTMENT STEP QTADV1A.78
*,PSTAR(P_FIELD) !IN PSTAR FIELD AT NEW TIME-LEVEL QTADV1A.79
*,PSTAR_OLD(P_FIELD) !IN PSTAR AT PREVIOUS TIME-LEVEL QTADV1A.80
*,RS(P_FIELD,P_LEVELS) !IN RS FIELD QTADV1A.81
QTADV1A.82
REAL QTADV1A.83
* DELTA_AK(P_LEVELS) !IN LAYER THICKNESS QTADV1A.84
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS QTADV1A.85
*,AKH(P_LEVELS+1) !IN HYBRID CO-ORDINATE AT HALF LEVELS QTADV1A.86
*,BKH(P_LEVELS+1) !IN HYBRID CO-ORDINATE AT HALF LEVELS QTADV1A.87
*,SEC_P_LATITUDE(P_FIELD) !IN 1/COS(LAT) AT P POINTS (2-D ARRAY) QTADV1A.88
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) QTADV1A.89
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) QTADV1A.90
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) QTADV1A.91
*,ADVECTION_TIMESTEP !IN QTADV1A.92
*,NU_BASIC !IN STANDARD NU TERM FOR MODEL RUN. QTADV1A.93
*,TRIGS(ROW_LENGTH) !IN HOLDS TRIGONOMETRIC FUNCTIONS USED QTADV1A.94
* ! IN FILTERING. QTADV1A.95
QTADV1A.96
REAL QTADV1A.97
* QT(P_FIELD,Q_LEVELS) !INOUT QT FIELD. QTADV1A.98
* ! MASS-WEIGHTED ON OUTPUT. QTADV1A.99
QTADV1A.100
C*--------------------------------------------------------------------- QTADV1A.101
QTADV1A.102
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- QTADV1A.103
C DEFINE LOCAL ARRAYS: 23 ARE REQUIRED QTADV1A.104
QTADV1A.105
REAL QTADV1A.106
* QT_FIRST_INC(P_FIELD,Q_LEVELS) ! HOLDS QT INCREMENT AAD2F304.131
* ! RETURNED BY FIRST CALL TO ADV_P_GD QTADV1A.108
*,QT_SECOND_INC(P_FIELD)! HOLDS QT INCREMENT QTADV1A.109
* !RETURNED BY SECOND CALL TO ADV_P_GD QTADV1A.110
*,QT_PROV(P_FIELD,Q_LEVELS) ! HOLDS PROVISIONAL VALUE OF QT AAD2F304.132
QTADV1A.123
QTADV1A.124
REAL QTADV1A.125
* NUX(P_FIELD,Q_LEVELS) ! COURANT NUMBER DEPENDENT NU AT P PTS AAD2F304.133
* ! IN EAST-WEST ADVECTION. QTADV1A.127
*,NUY(P_FIELD,Q_LEVELS) ! COURANT NUMBER DEPENDENT NU AT P PTS AAD2F304.134
* ! IN NORTH-SOUTH ADVECTION. QTADV1A.129
QTADV1A.134
REAL QTADV1A.135
& ZERO(P_FIELD) ! ARRAY OF ZEROES. QTADV1A.136
*,QT_INCREMENT(P_FIELD,Q_LEVELS) QTADV1A.137
QTADV1A.138
REAL QTADV1A.139
* BRSP(P_FIELD,Q_LEVELS) !MASS TERM AT LEVEL K AAD2F304.135
C*--------------------------------------------------------------------- QTADV1A.144
C DEFINE LOCAL VARIABLES QTADV1A.145
INTEGER QTADV1A.146
* P_POINTS_UPDATE ! NUMBER OF P POINTS TO BE UPDATED. QTADV1A.147
* ! = ROWS*ROWLENGTH QTADV1A.148
*, U_POINTS_UPDATE ! NUMBER OF U POINTS TO BE UPDATED. QTADV1A.149
* ! = (ROWS-1)*ROWLENGTH QTADV1A.150
*, P_POINTS_REQUIRED ! NUMBER OF P POINTS AT WHICH VALUES ARE QTADV1A.155
* ! NEEDED TO UPDATE AT P_POINTS_UPDATE QTADV1A.156
*, U_POINTS_REQUIRED ! NUMBER OF U POINTS AT WHICH VALUES ARE QTADV1A.157
* ! NEEDED TO UPDATE AT U_POINTS_UPDATE QTADV1A.158
*, START_U_REQUIRED ! FIRST U POINT OF VALUES REQUIRED TO UPDATE QTADV1A.159
* ! AT P POINTS UPDATE. QTADV1A.160
*, END_U_REQUIRED ! LAST U POINT OF REQUIRED VALUES. QTADV1A.161
QTADV1A.162
C REAL SCALARS QTADV1A.163
REAL QTADV1A.164
& SCALAR1,SCALAR2,TIMESTEP QTADV1A.165
QTADV1A.166
C COUNT VARIABLES FOR DO LOOPS ETC. QTADV1A.167
INTEGER QTADV1A.168
& I,I1,J,K1,IK,K ATD1F400.958
*, FILTER_SPACE ! HORIZONTAL DIMENSION OF SPACE NEEDED IN FILTERING QTADV1A.170
* ! ROUTINE. QTADV1A.171
QTADV1A.172
QTADV1A.173
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- QTADV1A.174
EXTERNAL ADV_P_GD,POLAR,UV_TO_P,FILTER QTADV1A.175
*IF DEF,CRAY QTADV1A.176
INTEGER ISMIN QTADV1A.177
EXTERNAL ISMIN QTADV1A.178
*ENDIF QTADV1A.179
C*--------------------------------------------------------------------- QTADV1A.180
QTADV1A.181
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD. QTADV1A.182
CL--------------------------------------------------------------------- QTADV1A.183
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: QTADV1A.184
CL--------------------------------------------------------------------- QTADV1A.185
CL QTADV1A.186
CL--------------------------------------------------------------------- QTADV1A.187
CL SECTION 1. INITIALISATION QTADV1A.188
CL--------------------------------------------------------------------- QTADV1A.189
C INCLUDE LOCAL CONSTANTS FROM GENERAL CONSTANTS BLOCK QTADV1A.190
QTADV1A.191
P_POINTS_UPDATE = upd_P_ROWS*ROW_LENGTH APB0F401.1111
U_POINTS_UPDATE = upd_U_ROWS*ROW_LENGTH APB0F401.1112
P_POINTS_REQUIRED = (upd_P_ROWS+2)*ROW_LENGTH APB0F401.1113
U_POINTS_REQUIRED = (upd_U_ROWS+2)*ROW_LENGTH APB0F401.1114
START_U_REQUIRED = START_POINT_NO_HALO-ROW_LENGTH APB0F401.1115
END_U_REQUIRED = END_U_POINT_NO_HALO+ROW_LENGTH APB0F401.1116
AAD2F304.136
C *IF -DEF,NOWHBR replaced by LWHITBROM logical AAD2F304.137
IF (LWHITBROM) THEN AAD2F304.138
CL CALCULATE BRSP TERM AT LEVEL K AAD2F304.139
AAD2F304.140
K=1 AAD2F304.141
! Loop over entire field APB0F401.1117
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1118
BRSP(I,K)=(3.*RS(I,K)+RS(I,K+1))*(RS(I,K)-RS(I,K+1)) AAD2F304.143
* *BKH(K+1)*.25*(PSTAR(I)-PSTAR_OLD(I)) AAD2F304.144
ENDDO AAD2F304.145
K=Q_LEVELS AAD2F304.146
! Loop over entire field APB0F401.1119
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1120
BRSP(I,K)=-(3.*RS(I,K)+RS(I,K-1))*(RS(I,K)-RS(I,K-1)) AAD2F304.148
* *BKH(K)*.25*(PSTAR(I)-PSTAR_OLD(I)) AAD2F304.149
ENDDO AAD2F304.150
AAD2F304.151
DO K=2,Q_LEVELS -1 AAD2F304.152
! Loop over entire field APB0F401.1121
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1122
BRSP(I,K)=((3.*RS(I,K)+RS(I,K+1))*(RS(I,K)-RS(I,K+1))*BKH(K+1) AAD2F304.154
* *.25*(PSTAR(I)-PSTAR_OLD(I))) AAD2F304.155
* -((3.*RS(I,K)+RS(I,K-1))*(RS(I,K)-RS(I,K-1))*BKH(K) AAD2F304.156
* *.25*(PSTAR(I)-PSTAR_OLD(I))) AAD2F304.157
ENDDO AAD2F304.158
AAD2F304.159
ENDDO AAD2F304.160
END IF AAD2F304.161
C *ENDIF AAD2F304.162
AAD2F304.163
! Loop over entire field APB0F401.1123
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1124
ZERO(I) = 0. QTADV1A.218
END DO ATD1F400.960
QTADV1A.220
CL LOOP OVER Q_LEVELS+1. QTADV1A.221
CL ON 1 TO Q_LEVELS PROVISIONAL VALUES OF THE FIELD ARE CALCULATED. QTADV1A.222
CL ON 2 TO Q_LEVELS+1 THE FINAL INCREMENTS ARE CALCULATED AND ADDED QTADV1A.223
CL ON. THE REASON FOR THIS LOGIC IS THAT THE PROVISIONAL VALUE AT QTADV1A.224
CL LEVEL K+1 IS NEEDED BEFORE THE FINAL INCREMENT AT LEVEL K CAN BE QTADV1A.225
CL CALCULATED. QTADV1A.226
QTADV1A.227
DO K=1,Q_LEVELS+1 ATD1F400.961
QTADV1A.230
TIMESTEP = ADVECTION_TIMESTEP QTADV1A.231
QTADV1A.250
CL IF NOT AT Q_LEVELS+1 THEN QTADV1A.251
IF(K.LE.Q_LEVELS) THEN QTADV1A.252
QTADV1A.253
CL--------------------------------------------------------------------- QTADV1A.254
CL SECTION 2. CALCULATE COURANT NUMBER DEPENDENT NU IF IN QTADV1A.255
CL FORECAST MODE. CALCULATE PROVISIONAL VALUES OF QTADV1A.256
CL QT AT NEW TIME-LEVEL. QTADV1A.257
CL--------------------------------------------------------------------- QTADV1A.258
QTADV1A.259
C --------------------------------------------------------------------- QTADV1A.260
CL SECTION 2.1 SET NU TO NU_BASIC DEPENDENT ON MAX COURANT QTADV1A.261
CL NUMBER. QTADV1A.262
C --------------------------------------------------------------------- QTADV1A.263
CL IF NU_BASIC NOT SET TO ZERO QTADV1A.264
IF(.NOT.L_SECOND) THEN QTADV1A.265
CL THEN SET NU DEPENDING ON NU_BASIC AND MAX QTADV1A.266
CL COURANT NUMBER. QTADV1A.267
CL CALCULATE COURANT NUMBER QTADV1A.268
C NOTE: RS AND TRIG TERMS WILL BE INCLUDED AFTER INTERPOLATION TO P QTADV1A.269
C GRID. QTADV1A.270
CL CALL UV_TO_P TO MOVE MEAN VELOCITIES ONTO P GRID QTADV1A.271
QTADV1A.272
CALL UV_TO_P(U_MEAN(START_U_REQUIRED,K), QTADV1A.273
* NUX(START_POINT_NO_HALO,K),U_POINTS_REQUIRED, APB0F401.1125
* P_POINTS_UPDATE,ROW_LENGTH,upd_P_ROWS+1) APB0F401.1126
QTADV1A.276
CALL UV_TO_P(V_MEAN(START_U_REQUIRED,K), QTADV1A.277
* NUY(START_POINT_NO_HALO,K),U_POINTS_REQUIRED, APB0F401.1127
* P_POINTS_UPDATE,ROW_LENGTH,upd_P_ROWS+1) APB0F401.1128
QTADV1A.280
CL CALCULATE NU FROM COURANT NUMBER INCLUDING TRIG AND RS TERMS. QTADV1A.281
! Loop over field missing top and bottom rows APB0F401.1129
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1130
NUX(I,K) = NUX(I,K)*LONGITUDE_STEP_INVERSE AAD2F304.190
NUY(I,K) = NUY(I,K)*LATITUDE_STEP_INVERSE AAD2F304.191
SCALAR1 = TIMESTEP/(RS(I,K)* QTADV1A.285
* RS(I,K)*(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I))) QTADV1A.286
SCALAR2 = SEC_P_LATITUDE(I)*SCALAR1 QTADV1A.287
SCALAR1 = SCALAR1*SCALAR1 QTADV1A.288
SCALAR2 = SCALAR2*SCALAR2 QTADV1A.289
NUX(I,K) = (1. - NUX(I,K)*NUX(I,K)*SCALAR2)*NU_BASIC AAD2F304.192
NUY(I,K) = (1. - NUY(I,K)*NUY(I,K)*SCALAR1)*NU_BASIC AAD2F304.193
END DO ATD1F400.963
QTADV1A.293
C SET NUX EQUAL TO MINIMUM VALUE ALONG EACH ROW QTADV1A.294
DO J=1,upd_P_ROWS APB0F401.1131
I1 = START_POINT_NO_HALO+(J-1)*ROW_LENGTH APB0F401.1132
*IF DEF,CRAY QTADV1A.301
IK=ISMIN(ROW_LENGTH,NUX(I1,K),1) AAD2F304.194
SCALAR1 = NUX(IK+I1-1,K) AAD2F304.195
*ELSE QTADV1A.304
SCALAR1 = NUX(I1,K) GRB0F405.108
DO I=I1+1,I1+ROW_LENGTH-1 GRB0F405.109
IF(NUX(I,K).LT.SCALAR1) THEN GRB0F405.110
SCALAR1 = NUX(I,K) GRB0F405.111
END IF GRB0F405.112
END DO GRB0F405.113
*ENDIF QTADV1A.310
IF(SCALAR1.LT.0.) SCALAR1=0. QTADV1A.311
DO I=I1,I1+ROW_LENGTH-1 ATD1F400.966
NUX(I,K) = SCALAR1 AAD2F304.198
END DO ATD1F400.967
END DO QTADV1A.315
QTADV1A.316
C SET NUY EQUAL TO MINIMUM VALUE ALONG EACH COLUMN QTADV1A.317
DO J=1,ROW_LENGTH QTADV1A.322
I1 = START_POINT_NO_HALO+J-1 APB0F401.1133
*IF DEF,CRAY QTADV1A.324
IK=ISMIN(upd_P_ROWS,NUY(I1,K),ROW_LENGTH) APB0F401.1134
SCALAR1 = NUY((IK-1)*ROW_LENGTH+I1,K) GPB5F403.5
*ELSE QTADV1A.327
SCALAR1 = NUY(I1,K) GRB0F405.114
DO I=I1+ROW_LENGTH,END_P_POINT_NO_HALO,ROW_LENGTH GRB0F405.115
IF(NUY(I,K).LT.SCALAR1) THEN GRB0F405.116
SCALAR1 = NUY(I,K) GRB0F405.117
END IF GRB0F405.118
END DO GRB0F405.119
*ENDIF QTADV1A.333
IF(SCALAR1.LT.0.) SCALAR1=0. QTADV1A.334
DO I=I1,END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.1136
NUY(I,K) = SCALAR1 AAD2F304.203
END DO QTADV1A.337
END DO QTADV1A.338
END IF QTADV1A.339
QTADV1A.340
CL QTADV1A.371
C --------------------------------------------------------------------- QTADV1A.372
CL SECTION 2.3 CALL ADV_P_GD TO OBTAIN FIRST INCREMENT DUE TO QTADV1A.373
CL ADVECTION. QTADV1A.374
C --------------------------------------------------------------------- QTADV1A.375
QTADV1A.376
CL CALL ADV_P_GD FOR QT. QTADV1A.377
K1=K+1 QTADV1A.378
QTADV1A.379
IF(K.EQ.Q_LEVELS) THEN AAD2F304.204
K1=K-1 AAD2F304.205
CALL ADV_P_GD(QT(1,K1),QT(1,K),QT(1,K1), AAD2F304.206
* U_MEAN(1,K),V_MEAN(1,K),ETADOT_MEAN(1,K),ZERO, AAD2F304.207
* SEC_P_LATITUDE, AAD2F304.208
* QT_FIRST_INC(1,K),NUX(1,K),NUY(1,K),P_FIELD, AAD2F304.209
* U_FIELD,ROW_LENGTH, APB0F401.1137
*CALL ARGFLDPT APB0F401.1138
& TIMESTEP,LATITUDE_STEP_INVERSE, QTADV1A.385
* LONGITUDE_STEP_INVERSE,SEC_U_LATITUDE, QTADV1A.386
* BRSP(1,K),L_SECOND,LWHITBROM) AAD2F304.210
ELSE IF(K.EQ.1)THEN AAD2F304.211
QTADV1A.389
C PASS ANY QT VALUES FOR LEVEL K-1 AS ETADOT AT LEVEL 1 AAD2F304.212
C IS SET TO ZERO BY USING ARRAY ZERO. AAD2F304.213
QTADV1A.395
CALL ADV_P_GD(QT(1,K1),QT(1,K),QT(1,K1), AAD2F304.214
* U_MEAN(1,K),V_MEAN(1,K),ZERO, QTADV1A.397
* ETADOT_MEAN(1,K1), AAD2F304.215
* SEC_P_LATITUDE,QT_FIRST_INC(1,K), AAD2F304.216
* NUX(1,K),NUY(1,K), AAD2F304.217
* P_FIELD,U_FIELD,ROW_LENGTH, APB0F401.1139
*CALL ARGFLDPT APB0F401.1140
& TIMESTEP, APB0F401.1141
* LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AAD2F304.220
* SEC_U_LATITUDE,BRSP(1,K),L_SECOND,LWHITBROM) AAD2F304.221
ELSE AAD2F304.222
CALL ADV_P_GD(QT(1,K-1),QT(1,K),QT(1,K1), AAD2F304.223
* U_MEAN(1,K),V_MEAN(1,K),ETADOT_MEAN(1,K), AAD2F304.224
* ETADOT_MEAN(1,K1), AAD2F304.225
* SEC_P_LATITUDE,QT_FIRST_INC(1,K), AAD2F304.226
* NUX(1,K),NUY(1,K), AAD2F304.227
* P_FIELD,U_FIELD,ROW_LENGTH, APB0F401.1142
*CALL ARGFLDPT APB0F401.1143
& TIMESTEP, APB0F401.1144
* LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AAD2F304.230
* SEC_U_LATITUDE,BRSP(1,K),L_SECOND,LWHITBROM) AAD2F304.231
END IF QTADV1A.403
QTADV1A.404
C --------------------------------------------------------------------- QTADV1A.405
CL SECTION 2.4 REMOVE MASS-WEIGHTING FROM INCREMENT AND ADD ONTO QTADV1A.406
CL FIELD TO OBTAIN PROVISIONAL VALUE. QTADV1A.407
C --------------------------------------------------------------------- QTADV1A.408
QTADV1A.409
! Loop over field, missing top and bottom rows APB0F401.1145
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1146
SCALAR1 = RS(I,K)*RS(I,K) QTADV1A.411
* *(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I)) QTADV1A.412
QT_FIRST_INC(I,K) = QT_FIRST_INC(I,K)/SCALAR1 AAD2F304.232
QT_PROV(I,K) = QT(I,K)-QT_FIRST_INC(I,K) AAD2F304.233
END DO ATD1F400.969
*IF DEF,GLOBAL QTADV1A.416
CL GLOBAL MODEL THEN CALCULATE PROVISIONAL POLAR VALUE. QTADV1A.417
! Fujitsu vectorization directive GRB0F405.120
!OCL NOVREC GRB0F405.121
DO I=1,ROW_LENGTH ATD1F400.970
C NORTH POLE. QTADV1A.419
IK = P_FIELD - ROW_LENGTH + I QTADV1A.420
QT_PROV(I,K) = QT(I,K) AAD2F304.234
QT_FIRST_INC(I,K) = -QT_FIRST_INC(I,K)/(RS(I,K)*RS(I,K) AAD2F304.235
* *(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I))) QTADV1A.423
C SOUTH POLE. QTADV1A.424
QT_PROV(IK,K) = QT(IK,K) AAD2F304.236
QT_FIRST_INC(IK,K) = -QT_FIRST_INC(IK,K)/(RS(IK,K)*RS(IK,K) AAD2F304.237
* *(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(IK))) QTADV1A.427
END DO ATD1F400.971
QTADV1A.429
CL CALL POLAR TO OBTAIN PROVISIONAL VALUE. QTADV1A.430
QTADV1A.431
QTADV1A.434
QTADV1A.435
*ELSE QTADV1A.436
CL LIMITED AREA MODEL THEN SET PROVISIONAL VALUES ON BOUNDARIES QTADV1A.437
CL EQUAL TO QT AT OLD TIME LEVEL. QTADV1A.438
DO I=1,ROW_LENGTH ATD1F400.972
IK = P_FIELD - ROW_LENGTH + I QTADV1A.440
QT_PROV(I,K) = QT(I,K) AAD2F304.240
QT_PROV(IK,K) = QT(IK,K) AAD2F304.241
END DO ATD1F400.973
*ENDIF QTADV1A.444
QTADV1A.445
END IF QTADV1A.446
CL END CONDITIONAL ON LEVEL BEING LESS THAN Q_LEVELS+1 QTADV1A.447
enddo AAD2F304.242
*IF DEF,GLOBAL APB2F401.1
CALL POLAR(QT_PROV,QT_FIRST_INC,QT_FIRST_INC, APB2F401.2
*CALL ARGFLDPT APB2F401.3
& P_FIELD,P_FIELD,P_FIELD, APB2F401.4
& TOP_ROW_START,P_BOT_ROW_START, APB2F401.5
& ROW_LENGTH,Q_LEVELS) APB2F401.6
*ENDIF APB2F401.7
CL BEGIN CONDITIONAL ON LEVEL BEING GREATER THAN 1 QTADV1A.448
DO K=1,Q_LEVELS+1 ATD1F400.974
IF(K.GT.1) THEN ATD1F400.975
CL--------------------------------------------------------------------- QTADV1A.450
CL SECTION 3. ALL WORK IN THIS SECTION PERFORMED AT LEVEL-1. QTADV1A.451
CL CALCULATE SECOND INCREMENT DUE TO ADVECTION. QTADV1A.452
CL CALCULATE TOTAL INCREMENT TO FIELD AND FILTER QTADV1A.453
CL WHERE NECESSARY THEN UPDATE FIELD. QTADV1A.454
CL THE POLAR INCREMENTS ARE THEN CALCULATED AND ADDED QTADV1A.455
CL ON BY CALLING POLAR. QTADV1A.456
CL--------------------------------------------------------------------- QTADV1A.457
QTADV1A.459
TIMESTEP = ADVECTION_TIMESTEP QTADV1A.460
QTADV1A.464
C --------------------------------------------------------------------- QTADV1A.465
CL SECTION 3.1 CALL ADV_P_GD TO OBTAIN SECOND INCREMENT DUE TO QTADV1A.466
CL ADVECTION. QTADV1A.467
C --------------------------------------------------------------------- QTADV1A.468
QTADV1A.469
K1=K-1 QTADV1A.470
C K1 HOLDS K-1. QTADV1A.471
QTADV1A.472
IF(K.GT.Q_LEVELS) THEN AAD2F304.245
C THE ZERO VERTICAL FLUX AT THE TOP IS ENSURED BY PASSING ETADOT AS AAD2F304.246
C ZERO. AAD2F304.247
AAD2F304.248
CALL ADV_P_GD(QT_PROV(1,K-2),QT_PROV(1,K-1), AAD2F304.249
* QT_PROV(1,K-2), AAD2F304.250
* U_MEAN(1,K1),V_MEAN(1,K1),ETADOT_MEAN(1,K-1), AAD2F304.251
* ZERO,SEC_P_LATITUDE, AAD2F304.252
* QT_SECOND_INC,NUX(1,K-1),NUY(1,K-1),P_FIELD, AAD2F304.253
* U_FIELD,ROW_LENGTH, APB0F401.1147
*CALL ARGFLDPT APB0F401.1148
& TIMESTEP,LATITUDE_STEP_INVERSE, AAD2F304.255
* LONGITUDE_STEP_INVERSE,SEC_U_LATITUDE, QTADV1A.480
* BRSP(1,K-1),L_SECOND,LWHITBROM) AAD2F304.256
QTADV1A.483
ELSE IF(K.EQ.2) THEN AAD2F304.257
QTADV1A.489
C THE ZERO VERTICAL FLUX AT THE BOTTOM IS ENSURED BY PASSING ETADOT AS AAD2F304.258
C ZERO. AAD2F304.259
QTADV1A.490
CALL ADV_P_GD(QT_PROV(1,K),QT_PROV(1,K-1), AAD2F304.260
* QT_PROV(1,K), AAD2F304.261
* U_MEAN(1,K1),V_MEAN(1,K1),ZERO, QTADV1A.492
* ETADOT_MEAN(1,K), AAD2F304.262
* SEC_P_LATITUDE,QT_SECOND_INC, AAD2F304.263
* NUX(1,K-1),NUY(1,K-1), AAD2F304.264
* P_FIELD,U_FIELD,ROW_LENGTH, AAD2F304.265
*CALL ARGFLDPT APB0F401.1149
& TIMESTEP, APB0F401.1150
* LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AAD2F304.267
* SEC_U_LATITUDE, AAD2F304.268
* BRSP(1,K-1),L_SECOND,LWHITBROM) AAD2F304.269
ELSE AAD2F304.270
AAD2F304.271
CALL ADV_P_GD(QT_PROV(1,K-2),QT_PROV(1,K-1), AAD2F304.272
* QT_PROV(1,K), AAD2F304.273
* U_MEAN(1,K1),V_MEAN(1,K1),ETADOT_MEAN(1,K-1), AAD2F304.274
* ETADOT_MEAN(1,K), AAD2F304.275
* SEC_P_LATITUDE,QT_SECOND_INC, AAD2F304.276
* NUX(1,K-1),NUY(1,K-1), AAD2F304.277
* P_FIELD,U_FIELD,ROW_LENGTH, AAD2F304.278
*CALL ARGFLDPT APB0F401.1151
& TIMESTEP, APB0F401.1152
* LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AAD2F304.280
* SEC_U_LATITUDE, AAD2F304.281
* BRSP(1,K-1),L_SECOND,LWHITBROM) AAD2F304.282
AAD2F304.283
END IF QTADV1A.498
QTADV1A.499
C --------------------------------------------------------------------- QTADV1A.500
CL SECTION 3.2 CALCULATE TOTAL MASS-WEIGHTED INCREMENT TO FIELD. QTADV1A.501
C --------------------------------------------------------------------- QTADV1A.502
QTADV1A.503
C TOTAL MASS-WEIGHTED INCREMENT IS CALCULATED AND THEN STORED IN QTADV1A.504
C QT_INCREMENT. QTADV1A.505
QTADV1A.506
! Loop over field, missing top and bottom rows APB0F401.1153
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1154
QT_INCREMENT(I,K1) = .5*(QT_SECOND_INC(I) + QTADV1A.508
* QT_FIRST_INC(I,K-1)*RS(I,K1)*RS(I,K1) AAD2F304.284
* *(DELTA_AK(K1)+DELTA_BK(K1)*PSTAR(I))) QTADV1A.510
END DO ATD1F400.977
QTADV1A.512
C --------------------------------------------------------------------- QTADV1A.513
CL SECTION 3.3 IF GLOBAL MODEL CALCULATE POLAR INCREMENTS. QTADV1A.514
CL IF LIMITED AREA MASS-WEIGHT BOUNDARY VALUES. QTADV1A.515
C --------------------------------------------------------------------- QTADV1A.516
QTADV1A.517
CL GLOBAL MODEL SO CALCULATE POLAR INCREMENT. QTADV1A.518
CL CALCULATE MERIDIONAL FLUX AROUND POLES BY ADDING THE TWO QTADV1A.519
CL INCREMENTS AND ALSO MASS-WEIGHTING POLAR FIELDS. QTADV1A.520
C NEGATIVE SIGN BEFORE FIRST INCS IS DUE TO THEIR SIGN BEING CHANGED QTADV1A.521
C PRIOR TO THE INTERMEDIATE VALUE BEING CALCULATED. QTADV1A.522
QTADV1A.523
! Fujitsu vectorization directive GRB0F405.122
!OCL NOVREC GRB0F405.123
DO I=1,ROW_LENGTH ATD1F400.978
C NORTH POLE OR NORTHERN BOUNDARY. QTADV1A.525
IK = P_FIELD - ROW_LENGTH + I QTADV1A.526
SCALAR1 = RS(I,K1)*RS(I,K1) QTADV1A.527
* *(DELTA_AK(K1)+DELTA_BK(K1)*PSTAR(I)) QTADV1A.528
*IF DEF,GLOBAL QTADV1A.529
QT_INCREMENT(I,K1) = -.5*(QT_SECOND_INC(I) QTADV1A.530
* - QT_FIRST_INC(I,K-1)*SCALAR1) AAD2F304.285
*ENDIF QTADV1A.532
QT(I,K1) = QT(I,K1)*SCALAR1 QTADV1A.533
C SOUTH POLE OR SOUTHERN BOUNDARY. QTADV1A.534
SCALAR2 = RS(IK,K1)*RS(IK,K1) QTADV1A.535
* *(DELTA_AK(K1)+DELTA_BK(K1)*PSTAR(IK)) QTADV1A.536
*IF DEF,GLOBAL QTADV1A.537
QT_INCREMENT(IK,K1) = -.5*(QT_SECOND_INC(IK) QTADV1A.538
* - QT_FIRST_INC(IK,K-1)*SCALAR2) AAD2F304.286
*ENDIF QTADV1A.540
QT(IK,K1) = QT(IK,K1)*SCALAR2 QTADV1A.541
END DO ATD1F400.979
QTADV1A.543
CL END CONDITIONAL LEVEL GREATER THAN ONE QTADV1A.544
END IF QTADV1A.545
QTADV1A.546
CL END LOOP OVER Q_LEVELS+1 QTADV1A.547
enddo AAD2F304.287
QTADV1A.549
CL--------------------------------------------------------------------- QTADV1A.550
CL SECTION 4 IF GLOBAL MODEL THEN FILTER INCREMENTS AND QTADV1A.551
CL UPDATE POLAR VALUES BY CALLING POLAR. QTADV1A.552
CL UPDATE ALL OTHER VALUES. QTADV1A.553
CL--------------------------------------------------------------------- QTADV1A.554
QTADV1A.555
*IF DEF,GLOBAL QTADV1A.556
C --------------------------------------------------------------------- QTADV1A.557
CL SECTION 4.1 CALL FILTER TO DO FILTERING. QTADV1A.558
C --------------------------------------------------------------------- QTADV1A.559
QTADV1A.560
C SET FILTER_SPACE WHICH IS ROW_LENGTH+2 TIMES THE NUMBER OF ROWS TO QTADV1A.561
C BE FILTERED. QTADV1A.562
QTADV1A.563
FILTER_SPACE = (ROW_LENGTH+2)*(NORTHERN_FILTERED_P_ROW-1+ QTADV1A.564
* P_FIELD/ROW_LENGTH-SOUTHERN_FILTERED_P_ROW) QTADV1A.565
CL CALL FILTER FOR QT INCREMENTS QTADV1A.566
QTADV1A.567
CALL FILTER(QT_INCREMENT,P_FIELD,Q_LEVELS, APB0F402.20
& FILTER_SPACE,ROW_LENGTH, APB0F402.21
*CALL ARGFLDPT APB0F402.22
& FILTER_WAVE_NUMBER_P_ROWS,TRIGS,IFAX, APB0F402.23
* NORTHERN_FILTERED_P_ROW,SOUTHERN_FILTERED_P_ROW) QTADV1A.571
QTADV1A.572
C --------------------------------------------------------------------- QTADV1A.573
CL SECTION 4.2 CALL POLAR TO UPDATE POLAR VALUES QTADV1A.574
C --------------------------------------------------------------------- QTADV1A.575
QTADV1A.576
CALL POLAR(QT,QT_INCREMENT,QT_INCREMENT, APB2F401.8
*CALL ARGFLDPT APB2F401.9
& P_FIELD,P_FIELD,P_FIELD, APB2F401.10
& TOP_ROW_START,P_BOT_ROW_START, APB2F401.11
& ROW_LENGTH,Q_LEVELS) APB2F401.12
QTADV1A.582
*ENDIF QTADV1A.583
C --------------------------------------------------------------------- QTADV1A.584
CL SECTION 4.3 UPDATE ALL OTHER POINTS. QTADV1A.585
C --------------------------------------------------------------------- QTADV1A.586
QTADV1A.587
DO K=1,Q_LEVELS ATD1F400.983
C UPDATE QT. QTADV1A.589
CFPP$ SELECT(CONCUR) QTADV1A.590
! Loop over field, missing top and bottom rows APB0F401.1155
DO I= START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1156
QT(I,K)=QT(I,K)*RS(I,K)*RS(I,K)* ATD1F400.985
& (DELTA_AK(K)+DELTA_BK(K)*PSTAR(I))-QT_INCREMENT(I,K) ATD1F400.986
END DO ATD1F400.987
END DO QTADV1A.614
CL END OF ROUTINE QT_ADV QTADV1A.615
QTADV1A.616
RETURN QTADV1A.617
END QTADV1A.618
*ENDIF QTADV1A.619