*IF DEF,A12_1B ARB2F400.8
C ******************************COPYRIGHT****************************** GTS2F400.10171
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10172
C GTS2F400.10173
C Use, duplication or disclosure of this code is subject to the GTS2F400.10174
C restrictions as set forth in the contract. GTS2F400.10175
C GTS2F400.10176
C Meteorological Office GTS2F400.10177
C London Road GTS2F400.10178
C BRACKNELL GTS2F400.10179
C Berkshire UK GTS2F400.10180
C RG12 2SZ GTS2F400.10181
C GTS2F400.10182
C If no contract has been raised with this copy of the code, the use, GTS2F400.10183
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10184
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10185
C Modelling at the above address. GTS2F400.10186
C ******************************COPYRIGHT****************************** GTS2F400.10187
C GTS2F400.10188
CLL SUBROUTINE TH_ADV ------------------------------------------- THADV1A.3
CLL THADV1A.4
CLL PURPOSE: CALCULATES MASS-WEIGHTED INCREMENTS TO THETAL THADV1A.5
CLL DUE TO ADVECTION BY USING EQUATION (35) TO CALCULATE PROVISIONAL THADV1A.6
CLL VALUES OF THETAL AT THE NEW TIME-LEVEL, AND THEN RECALCULATING THE THADV1A.7
CLL ADVECTION TERMS ON THE RIGHT-HAND SIDE OF (35) USING THESE THADV1A.8
CLL PROVISIONAL VALUES. THE FINAL INCREMENTS ARE CALCULATED AS IN THADV1A.9
CLL EQUATION (40). THOSE REQUIRING FILTERING ARE FILTERED AND ALL THE THADV1A.10
CLL INCREMENTS ARE ADDED ONTO THE FIELDS USING (40). IF RUNNING A THADV1A.11
CLL GLOBAL MODEL POLAR IS CALLED TO UPDATE POLAR VALUES. THADV1A.12
CLL THADV1A.13
CLL NOT SUITABLE FOR SINGLE COLUMN USE. THADV1A.14
CLL VERSION FOR CRAY Y-MP THADV1A.15
CLL THADV1A.16
CLL MM, DR <- PROGRAMMER OF SOME OR ALL OF PREVIOUS CODE OR CHANGES THADV1A.17
CLL THADV1A.18
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: THADV1A.19
CLL VERSION DATE THADV1A.20
CLL THADV1A.21
CLL 3.4 06/08/94 Code restructured to improve parallel efficiency AAD2F304.289
CLL on C90. AAD2F304.290
CLL Authors: A. Dickinson, D. Salmond AAD2F304.291
CLL Reviewer: M. Mawson AAD2F304.292
CLL AAD2F304.293
CLL 3.4 23/06/94 Argument LWHITBROM added and passed to ADV_P_GD GSS1F304.891
CLL S.J.Swarbrick GSS1F304.892
! 3.5 28/03/95 MPP code: Change updateable area and APB0F305.867
! add boundary swaps. P.Burton APB0F305.868
CLL GSS1F304.893
! 4.0 25/4/95 Corrected index for calculation of South Pole APB0F400.1
! values of THETAL_INCREMENT P.Burton APB0F400.2
CLL 4.0 14/02/95 Option to run with half_timestep at top level ATD1F400.915
CLL removed. Author: T Davies, Reviewer: M Mawson ATD1F400.916
! 4.1 29/04/96 Remove MPP code (new QTADV1C version for MPP) APB0F401.1157
! and add TYPFLDPT arguments P.Burton APB0F401.1158
!LL 4.2 16/08/96 Add TYPFLDPT arguments to FILTER subroutine APB0F402.33
!LL and make the FILTER_WAVE_NUMBER arrays APB0F402.34
!LL globally sized P.Burton APB0F402.35
!LL 4.2 30/10/96 Move declaration of TYPFLDPT variables to top of APB1F402.50
!LL declarations. P.Burton APB1F402.51
!LL 4.3 24/04/97 Fix to 4th order calculations - GPB5F403.14
!LL Calculation of NUY via ISMIN P.Burton GPB5F403.15
!LL 4.5 05/05/98 Recode -DEF,CRAY loops to find minimum of NUX/NUY GRB0F405.80
!LL to vectorize on Fujitsu VPP700. RBarnes@ecmwf.int GRB0F405.81
!LL 4.5 22/06/98 Fujitsu vectorization directives. R.Barnes. GRB0F405.82
!LL GRB0F405.83
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, THADV1A.22
CLL STANDARD B. THADV1A.23
CLL THADV1A.24
CLL SYSTEM COMPONENTS COVERED: P121 THADV1A.25
CLL THADV1A.26
CLL SYSTEM TASK: P1 THADV1A.27
CLL THADV1A.28
CLL DOCUMENTATION: THE EQUATIONS USED ARE (35) AND (40) THADV1A.29
CLL IN UNIFIED MODEL DOCUMENTATION PAPER NO. 10 THADV1A.30
CLL M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON THADV1A.31
CLL THADV1A.32
CLLEND------------------------------------------------------------- THADV1A.33
THADV1A.34
C*L ARGUMENTS:--------------------------------------------------- THADV1A.35
SUBROUTINE TH_ADV 1,59THADV1A.36
1 (THETAL,PSTAR_OLD,PSTAR,U_MEAN,V_MEAN, THADV1A.37
2 SEC_P_LATITUDE,ETADOT_MEAN,RS,DELTA_AK,DELTA_BK, THADV1A.38
3 LATITUDE_STEP_INVERSE,ADVECTION_TIMESTEP,NU_BASIC, THADV1A.39
4 LONGITUDE_STEP_INVERSE,NORTHERN_FILTERED_P_ROW, THADV1A.40
5 SOUTHERN_FILTERED_P_ROW,P_LEVELS, THADV1A.41
6 U_FIELD,P_FIELD,ROW_LENGTH, APB0F401.1159
*CALL ARGFLDPT 
APB0F401.1160
7 TRIGS,IFAX,FILTER_WAVE_NUMBER_P_ROWS,SEC_U_LATITUDE, APB0F401.1161
8 AKH,BKH,QCL,QCF,P_EXNER,OMEGA, THADV1A.44
9 Q_LEVELS,AK,BK,L_SECOND, ATD1F400.917
& LWHITBROM) GSS1F304.895
THADV1A.46
IMPLICIT NONE THADV1A.47
APB1F402.52
! All TYPFLDPT arguments are intent IN APB1F402.53
*CALL TYPFLDPT APB1F402.54
THADV1A.48
INTEGER THADV1A.49
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. THADV1A.50
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID THADV1A.51
*, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. THADV1A.53
*, Q_LEVELS !IN NUMBER OF MOIST LEVELS. THADV1A.54
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW THADV1A.56
*, NORTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STOPS THADV1A.57
*, SOUTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STARTS AGAIN. THADV1A.58
&, FILTER_WAVE_NUMBER_P_ROWS(GLOBAL_P_FIELD/GLOBAL_ROW_LENGTH) APB0F402.36
& ! LAST WAVE NUMBER NOT TO BE CHOPPED APB0F402.37
*, IFAX(10) !IN HOLDS FACTORS OF ROW_LENGTH USED BY THADV1A.61
* ! FILTERING. THADV1A.62
APB0F401.1162
THADV1A.63
C LOGICAL VARIABLE THADV1A.64
LOGICAL THADV1A.65
* L_SECOND ! SET TO TRUE IF NU_BASIC IS ZERO. THADV1A.66
& ,LWHITBROM GSS1F304.896
THADV1A.69
REAL THADV1A.70
* THETAL(P_FIELD,P_LEVELS) !INOUT THETAL FIELD THADV1A.71
* ! MASS-WEIGHTED ON OUTPUT. THADV1A.72
THADV1A.73
REAL THADV1A.74
* U_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED U VELOCITY THADV1A.75
* ! FROM ADJUSTMENT STEP THADV1A.76
*,V_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED V VELOCITY THADV1A.77
* ! * COS(LAT) FROM ADJUSTMENT STEP THADV1A.78
*,ETADOT_MEAN(P_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED THADV1A.79
* !VERTICAL VELOCITY FROM ADJUSTMENT STEP THADV1A.80
*,PSTAR(P_FIELD) !IN PSTAR FIELD AT NEW TIME-LEVEL THADV1A.81
*,PSTAR_OLD(P_FIELD) !IN PSTAR AT PREVIOUS TIME-LEVEL THADV1A.82
*,RS(P_FIELD,P_LEVELS) !IN RS FIELD THADV1A.83
*,QCL(P_FIELD,Q_LEVELS) !IN. PRIMARY ARRAY FOR QCL THADV1A.84
*,QCF(P_FIELD,Q_LEVELS) !IN. PRIMARY ARRAY FOR QCF THADV1A.85
*,OMEGA(U_FIELD,P_LEVELS) !IN. TRUE VERTICAL VELOCITY DP/DT THADV1A.86
*,P_EXNER(P_FIELD,P_LEVELS+1) !IN. PRIMARY ARRAY FOR EXNER FUNCTION THADV1A.87
THADV1A.88
REAL THADV1A.89
* DELTA_AK(P_LEVELS) !IN LAYER THICKNESS THADV1A.90
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS THADV1A.91
*,AK(P_LEVELS) !IN HYBRID CO-ORDINATE AT FULL LEVELS THADV1A.92
*,BK(P_LEVELS) !IN HYBRID CO-ORDINATE AT FULL LEVELS THADV1A.93
*,AKH(P_LEVELS+1) !IN HYBRID CO-ORDINATE AT HALF LEVELS THADV1A.94
*,BKH(P_LEVELS+1) !IN HYBRID CO-ORDINATE AT HALF LEVELS THADV1A.95
*,SEC_P_LATITUDE(P_FIELD) !IN 1/COS(LAT) AT P POINTS (2-D ARRAY) THADV1A.96
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) THADV1A.97
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) THADV1A.98
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) THADV1A.99
*,ADVECTION_TIMESTEP !IN THADV1A.100
*,NU_BASIC !IN STANDARD NU TERM FOR MODEL RUN. THADV1A.101
*,TRIGS(ROW_LENGTH) !IN HOLDS TRIGONOMETRIC FUNCTIONS USED THADV1A.102
* ! IN FILTERING. THADV1A.103
THADV1A.104
C*--------------------------------------------------------------------- THADV1A.105
THADV1A.106
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- THADV1A.107
C DEFINE LOCAL ARRAYS: 24 ARE REQUIRED. THADV1A.108
REAL THADV1A.109
& OMEGA_P(P_FIELD,P_LEVELS) ! HOLDS OMEGA AT P POINTS. APB2F401.13
THADV1A.111
REAL THADV1A.112
* THETAL_FIRST_INC(P_FIELD,P_LEVELS) ! HOLDS THETAL INCREMENT AAD2F304.294
* ! RETURNED BY FIRST CALL TO ADV_P_GD THADV1A.114
*,THETAL_SECOND_INC(P_FIELD)! HOLDS THETAL INCREMENT THADV1A.115
* ! RETURNED BY SECOND CALL TO ADV_P_GD THADV1A.116
*,THETAL_PROV(P_FIELD,P_LEVELS) ! HOLDS PROVISIONAL VALUE OF AAD2F304.295
* ! THETAL THADV1A.118
THADV1A.130
REAL THADV1A.131
* THETAL_INCREMENT(P_FIELD,P_LEVELS) !HOLDS INCREMENT TO THETAL AAD2F304.296
*,ZERO(P_FIELD) !A FIELD OF ZEROES USED WHERE VERTICAL THADV1A.135
* !VELOCITY IS ZERO. THADV1A.136
THADV1A.137
REAL THADV1A.138
* NUX(P_FIELD,P_LEVELS) !COURANT NBR DEPENDENT NU AT P PTS USED AAD2F304.297
* ! IN EAST-WEST ADVECTION. THADV1A.140
*,NUY(P_FIELD,P_LEVELS) !COURANT NBR DEPENDENT NU AT P PTS USED AAD2F304.298
* ! IN NORTH-SOUTH ADVECTION. THADV1A.142
REAL THADV1A.148
* BRSP(P_FIELD,P_LEVELS) !MASS TERM AT LEVEL K AAD2F304.299
THADV1A.153
C*--------------------------------------------------------------------- THADV1A.154
C DEFINE LOCAL VARIABLES THADV1A.155
INTEGER THADV1A.156
* P_POINTS_UPDATE ! NUMBER OF P POINTS TO BE UPDATED. THADV1A.157
* ! = ROWS*ROWLENGTH THADV1A.158
*, U_POINTS_UPDATE ! NUMBER OF U POINTS TO BE UPDATED. THADV1A.159
* ! = (ROWS-1)*ROWLENGTH THADV1A.160
*, P_POINTS_REQUIRED ! NUMBER OF P POINTS AT WHICH VALUES ARE THADV1A.165
* ! NEEDED TO UPDATE AT P_POINTS_UPDATE THADV1A.166
*, U_POINTS_REQUIRED ! NUMBER OF U POINTS AT WHICH VALUES ARE THADV1A.167
* ! NEEDED TO UPDATE AT U_POINTS_UPDATE THADV1A.168
*, START_U_REQUIRED ! FIRST U POINT OF VALUES REQUIRED TO UPDATE THADV1A.169
* ! AT P POINTS UPDATE. THADV1A.170
*, END_U_REQUIRED ! LAST U POINT OF REQUIRED VALUES. THADV1A.171
THADV1A.172
C REAL SCALARS THADV1A.173
REAL THADV1A.174
& SCALAR1,SCALAR2,CONST1,LC_LF,TIMESTEP THADV1A.175
&,PK, PK1 ! Pressure at half levels k and k1 (k1=k-1) THADV1A.176
&,P_EXNER_FULL ! Exner pressure at full model level THADV1A.177
THADV1A.178
C COUNT VARIABLES FOR DO LOOPS ETC. THADV1A.179
INTEGER THADV1A.180
& I,I1,J,K1,IK,K ATD1F400.918
*, FILTER_SPACE ! HORIZONTAL DIMENSION OF SPACE NEEDED IN FILTERING THADV1A.182
* ! ROUTINE. THADV1A.183
THADV1A.184
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- THADV1A.185
EXTERNAL ADV_P_GD,POLAR,UV_TO_P,FILTER THADV1A.186
*IF DEF,CRAY THADV1A.187
INTEGER ISMIN THADV1A.188
EXTERNAL ISMIN THADV1A.189
*ENDIF THADV1A.190
C*--------------------------------------------------------------------- THADV1A.191
CL CALL COMDECK TO GET PHYSICAL CONSTANTS USED. THADV1A.192
THADV1A.193
*CALL C_THADV THADV1A.194
THADV1A.195
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD. THADV1A.196
CL--------------------------------------------------------------------- THADV1A.197
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: THADV1A.198
CL--------------------------------------------------------------------- THADV1A.199
CL THADV1A.200
THADV1A.201
*CALL P_EXNERC THADV1A.202
THADV1A.203
CL--------------------------------------------------------------------- THADV1A.204
CL SECTION 1. INITIALISATION THADV1A.205
CL--------------------------------------------------------------------- THADV1A.206
C INCLUDE LOCAL CONSTANTS FROM GENERAL CONSTANTS BLOCK THADV1A.207
THADV1A.208
LC_LF = LC + LF THADV1A.209
P_POINTS_UPDATE = upd_P_ROWS*ROW_LENGTH APB0F401.1165
U_POINTS_UPDATE = upd_U_ROWS*ROW_LENGTH APB0F401.1166
P_POINTS_REQUIRED = (upd_P_ROWS+2)*ROW_LENGTH APB0F401.1167
U_POINTS_REQUIRED = (upd_U_ROWS+2)*ROW_LENGTH APB0F401.1168
START_U_REQUIRED = START_POINT_NO_HALO-ROW_LENGTH APB0F401.1169
END_U_REQUIRED = END_U_POINT_NO_HALO+ROW_LENGTH APB0F401.1170
AAD2F304.300
AAD2F304.301
C *IF -DEF,NOWHBR replaced by LWHITBROM logical AAD2F304.302
IF (LWHITBROM) THEN AAD2F304.303
CL CALCULATE BRSP TERM AT LEVEL K AAD2F304.304
AAD2F304.305
K=1 AAD2F304.306
! Loop over entire field APB0F401.1171
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1172
BRSP(I,K)=(3.*RS(I,K)+RS(I,K+1))*(RS(I,K)-RS(I,K+1)) AAD2F304.308
* *BKH(K+1)*.25*(PSTAR(I)-PSTAR_OLD(I)) AAD2F304.309
ENDDO AAD2F304.310
K=P_LEVELS AAD2F304.311
! Loop over entire field APB0F401.1173
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1174
BRSP(I,K)=-(3.*RS(I,K)+RS(I,K-1))*(RS(I,K)-RS(I,K-1)) AAD2F304.313
* *BKH(K)*.25*(PSTAR(I)-PSTAR_OLD(I)) AAD2F304.314
ENDDO AAD2F304.315
AAD2F304.316
DO K=2,P_LEVELS -1 AAD2F304.317
! Loop over entire field APB0F401.1175
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1176
BRSP(I,K)=((3.*RS(I,K)+RS(I,K+1))*(RS(I,K)-RS(I,K+1))*BKH(K+1) AAD2F304.319
* *.25*(PSTAR(I)-PSTAR_OLD(I))) AAD2F304.320
* -((3.*RS(I,K)+RS(I,K-1))*(RS(I,K)-RS(I,K-1))*BKH(K) AAD2F304.321
* *.25*(PSTAR(I)-PSTAR_OLD(I))) AAD2F304.322
ENDDO AAD2F304.323
AAD2F304.324
ENDDO AAD2F304.325
END IF AAD2F304.326
C *ENDIF AAD2F304.327
AAD2F304.328
AAD2F304.329
! Loop over entire field APB0F401.1177
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.1178
ZERO(I) = 0. THADV1A.236
END DO ATD1F400.920
THADV1A.238
CL LOOP OVER P_LEVELS+1. THADV1A.239
CL ON 1 TO P_LEVELS PROVISIONAL VALUES OF THE FIELD ARE CALCULATED. THADV1A.240
CL ON 2 TO P_LEVELS+1 THE FINAL INCREMENTS ARE CALCULATED AND ADDED THADV1A.241
CL ON. THE REASON FOR THIS LOGIC IS THAT THE PROVISIONAL VALUE AT THADV1A.242
CL LEVEL K+1 IS NEEDED BEFORE THE FINAL INCREMENT AT LEVEL K CAN BE THADV1A.243
CL CALCULATED. THADV1A.244
THADV1A.245
DO K=1,P_LEVELS+1 ATD1F400.922
THADV1A.248
TIMESTEP = ADVECTION_TIMESTEP THADV1A.249
CL IF NOT AT P_LEVELS+1 THEN THADV1A.269
IF(K.LE.P_LEVELS) THEN THADV1A.270
THADV1A.271
CL--------------------------------------------------------------------- THADV1A.272
CL SECTION 2. CALCULATE COURANT NUMBER DEPENDENT NU IF IN THADV1A.273
CL FORECAST MODE. AAD2F304.354
CL CALCULATE THADV1A.275
CL PROVISIONAL VALUES OF THETAL AT NEW TIME-LEVEL. THADV1A.276
CL--------------------------------------------------------------------- THADV1A.277
THADV1A.278
C --------------------------------------------------------------------- THADV1A.279
CL SECTION 2.1 SET NU TO NU_BASIC DEPENDENT ON MAX COURANT THADV1A.280
CL NUMBER. THADV1A.281
C --------------------------------------------------------------------- THADV1A.282
CL IF NU_BASIC IS ZERO THEN DO NOT BOTHER TO CALCULATE NU THADV1A.283
IF(.NOT.L_SECOND) THEN THADV1A.284
CL CALCULATE COURANT NUMBER THADV1A.285
C NOTE: RS AND TRIG TERMS WILL BE INCLUDED AFTER INTERPOLATION TO P THADV1A.286
C GRID. THADV1A.287
CL CALL UV_TO_P TO MOVE MEAN VELOCITIES ONTO P GRID THADV1A.288
THADV1A.289
CALL UV_TO_P(U_MEAN(START_U_REQUIRED,K), THADV1A.290
* NUX(START_POINT_NO_HALO,K),U_POINTS_REQUIRED, APB0F401.1179
* P_POINTS_UPDATE,ROW_LENGTH,upd_P_ROWS+1) APB0F401.1180
THADV1A.293
CALL UV_TO_P(V_MEAN(START_U_REQUIRED,K), THADV1A.294
* NUY(START_POINT_NO_HALO,K),U_POINTS_REQUIRED, APB0F401.1181
* P_POINTS_UPDATE,ROW_LENGTH,upd_P_ROWS+1) APB0F401.1182
THADV1A.297
CL CALCULATE NU FROM COURANT NUMBER INCLUDING TRIG AND RS TERMS. THADV1A.298
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1183
NUX(I,K) = NUX(I,K)*LONGITUDE_STEP_INVERSE AAD2F304.357
NUY(I,K) = NUY(I,K)*LATITUDE_STEP_INVERSE AAD2F304.358
SCALAR1 = TIMESTEP/(RS(I,K)* THADV1A.302
* RS(I,K)*(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I))) THADV1A.303
SCALAR2 = SEC_P_LATITUDE(I)*SCALAR1 THADV1A.304
SCALAR1 = SCALAR1*SCALAR1 THADV1A.305
SCALAR2 = SCALAR2*SCALAR2 THADV1A.306
NUX(I,K) = (1. - NUX(I,K)*NUX(I,K)*SCALAR2)*NU_BASIC AAD2F304.359
NUY(I,K) = (1. - NUY(I,K)*NUY(I,K)*SCALAR1)*NU_BASIC AAD2F304.360
END DO ATD1F400.924
THADV1A.310
C SET NUX EQUAL TO MINIMUM VALUE ALONG EACH ROW THADV1A.311
DO J = 1,upd_P_ROWS APB0F401.1184
I1 = START_POINT_NO_HALO+(J-1)*ROW_LENGTH APB0F401.1185
*IF DEF,CRAY THADV1A.318
IK=ISMIN(ROW_LENGTH,NUX(I1,K),1) AAD2F304.361
SCALAR1 = NUX(IK+I1-1,K) AAD2F304.362
*ELSE THADV1A.321
SCALAR1 = NUX(I1,K) GRB0F405.84
DO I=I1+1,I1+ROW_LENGTH-1 GRB0F405.85
IF(NUX(I,K).LT.SCALAR1) THEN GRB0F405.86
SCALAR1 = NUX(I,K) GRB0F405.87
END IF GRB0F405.88
END DO GRB0F405.89
*ENDIF THADV1A.327
IF(SCALAR1.LT.0.) SCALAR1=0. THADV1A.328
DO I=I1,I1+ROW_LENGTH-1 ATD1F400.927
NUX(I,K) = SCALAR1 AAD2F304.365
END DO ATD1F400.928
END DO THADV1A.332
THADV1A.333
C SET NUY EQUAL TO MINIMUM VALUE ALONG EACH COLUMN THADV1A.334
DO J = 1,ROW_LENGTH THADV1A.339
I1 = START_POINT_NO_HALO+ J-1 APB0F401.1186
*IF DEF,CRAY THADV1A.341
IK=ISMIN(upd_P_ROWS,NUY(I1,K),ROW_LENGTH) APB0F401.1187
SCALAR1 = NUY((IK-1)*ROW_LENGTH+I1,K) GPB5F403.16
*ELSE THADV1A.344
SCALAR1 = NUY(I1,K) GRB0F405.90
DO I=I1+ROW_LENGTH,END_P_POINT_NO_HALO,ROW_LENGTH GRB0F405.91
IF(NUY(I,K).LT.SCALAR1) THEN GRB0F405.92
SCALAR1 = NUY(I,K) GRB0F405.93
END IF GRB0F405.94
END DO GRB0F405.95
*ENDIF THADV1A.350
IF(SCALAR1.LT.0.) SCALAR1=0. THADV1A.351
DO I=I1,END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.1189
NUY(I,K) = SCALAR1 AAD2F304.370
END DO THADV1A.354
END DO THADV1A.355
END IF THADV1A.356
THADV1A.357
THADV1A.386
C --------------------------------------------------------------------- THADV1A.387
CL SECTION 2.2 CALL ADV_P_GD TO OBTAIN FIRST INCREMENT DUE TO AAD2F304.371
CL ADVECTION. THADV1A.389
C --------------------------------------------------------------------- THADV1A.390
THADV1A.391
CL CALL ADV_P_GD FOR THETAL. THADV1A.392
K1=K+1 THADV1A.393
THADV1A.394
IF(K.EQ.P_LEVELS) THEN THADV1A.395
C PASS ANY THETAL VALUES AS THOSE APPARENTLY AT LEVEL K+1 AS ETADOT THADV1A.396
C IS SET TO ZERO BY USING ARRAY ZERO. THADV1A.397
K1 = K-1 THADV1A.398
THADV1A.399
CALL ADV_P_GD(THETAL(1,K1),THETAL(1,K),THETAL(1,K1), AAD2F304.372
* U_MEAN(1,K),V_MEAN(1,K),ETADOT_MEAN(1,K),ZERO, AAD2F304.373
* SEC_P_LATITUDE, AAD2F304.374
* THETAL_FIRST_INC(1,K),NUX(1,K),NUY(1,K),P_FIELD, AAD2F304.375
* U_FIELD,ROW_LENGTH, APB0F401.1190
*CALL ARGFLDPT APB0F401.1191
& TIMESTEP,LATITUDE_STEP_INVERSE, THADV1A.404
* LONGITUDE_STEP_INVERSE,SEC_U_LATITUDE, THADV1A.405
* BRSP(1,K),L_SECOND,LWHITBROM) AAD2F304.376
ELSE IF(K.EQ.1)THEN AAD2F304.377
AAD2F304.378
C PASS ANY THETAL VALUES FOR LEVEL K-1 AS ETADOT AT LEVEL 1 AAD2F304.379
C IS SET TO ZERO BY USING ARRAY ZERO. AAD2F304.380
CALL ADV_P_GD(THETAL(1,K1),THETAL(1,K),THETAL(1,K1), AAD2F304.381
* U_MEAN(1,K),V_MEAN(1,K),ZERO, AAD2F304.382
* ETADOT_MEAN(1,K1), AAD2F304.383
* SEC_P_LATITUDE,THETAL_FIRST_INC(1,K), AAD2F304.384
* NUX(1,K),NUY(1,K), AAD2F304.385
* P_FIELD,U_FIELD,ROW_LENGTH, APB0F401.1192
*CALL ARGFLDPT APB0F401.1193
& TIMESTEP, APB0F401.1194
* LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AAD2F304.388
* SEC_U_LATITUDE,BRSP(1,K),L_SECOND,LWHITBROM) AAD2F304.389
ELSE THADV1A.407
CALL ADV_P_GD(THETAL(1,K-1),THETAL(1,K),THETAL(1,K1), AAD2F304.390
* U_MEAN(1,K),V_MEAN(1,K),ETADOT_MEAN(1,K), AAD2F304.391
* ETADOT_MEAN(1,K1), AAD2F304.392
* SEC_P_LATITUDE,THETAL_FIRST_INC(1,K), AAD2F304.393
* NUX(1,K),NUY(1,K), AAD2F304.394
* P_FIELD,U_FIELD,ROW_LENGTH, APB0F401.1195
*CALL ARGFLDPT APB0F401.1196
& TIMESTEP, APB0F401.1197
* LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, THADV1A.413
* SEC_U_LATITUDE,BRSP(1,K),L_SECOND,LWHITBROM) AAD2F304.395
THADV1A.415
END IF THADV1A.416
THADV1A.417
THADV1A.418
C --------------------------------------------------------------------- THADV1A.419
CL SECTION 2.3 REMOVE MASS-WEIGHTING FROM INCREMENT AND ADD ONTO AAD2F304.396
CL FIELD TO OBTAIN PROVISIONAL VALUE. THADV1A.421
C --------------------------------------------------------------------- THADV1A.422
THADV1A.423
! Loop over field, missing top and bottom rows. APB0F401.1198
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1199
SCALAR1 = RS(I,K)*RS(I,K) THADV1A.425
* *(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I)) THADV1A.426
THETAL_FIRST_INC(I,K)=THETAL_FIRST_INC(I,K)/SCALAR1 AAD2F304.397
THETAL_PROV(I,K) = THETAL(I,K)- THETAL_FIRST_INC(I,K) AAD2F304.398
END DO ATD1F400.930
THADV1A.430
*IF DEF,GLOBAL THADV1A.431
CL GLOBAL MODEL CALCULATE PROVISIONAL POLAR VALUE. THADV1A.432
! Fujitsu vectorization directive GRB0F405.96
!OCL NOVREC GRB0F405.97
DO I=1,ROW_LENGTH ATD1F400.931
C NORTH POLE. THADV1A.434
IK = P_FIELD - ROW_LENGTH + I THADV1A.435
THETAL_PROV(I,K) = THETAL(I,K) AAD2F304.399
THETAL_FIRST_INC(I,K) = -THETAL_FIRST_INC(I,K)/ AAD2F304.400
* (RS(I,K)*RS(I,K)*(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I))) THADV1A.438
C SOUTH POLE. THADV1A.439
THETAL_PROV(IK,K) = THETAL(IK,K) AAD2F304.401
THETAL_FIRST_INC(IK,K) = -THETAL_FIRST_INC(IK,K)/ AAD2F304.402
* (RS(IK,K)*RS(IK,K)* THADV1A.442
* (DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(IK))) THADV1A.443
END DO ATD1F400.932
THADV1A.445
THADV1A.450
THADV1A.451
*ELSE THADV1A.452
CL LIMITED AREA MODEL THEN SET PROVISIONAL VALUES ON BOUNDARIES THADV1A.453
CL TO FIELD VALUES AT OLD TIME LEVEL. THADV1A.454
DO I=1,ROW_LENGTH ATD1F400.933
THETAL_PROV(I,K) = THETAL(I,K) AAD2F304.405
IK = P_FIELD + I - ROW_LENGTH THADV1A.457
THETAL_PROV(IK,K) = THETAL(IK,K) AAD2F304.406
END DO ATD1F400.934
*ENDIF THADV1A.460
END IF THADV1A.461
CL END CONDITIONAL ON LEVEL BEING LESS THAN P_LEVELS+1 THADV1A.462
enddo AAD2F304.407
*IF DEF,GLOBAL APB2F401.14
APB2F401.15
CALL POLAR(THETAL_PROV,THETAL_FIRST_INC,THETAL_FIRST_INC, APB2F401.16
*CALL ARGFLDPT APB2F401.17
& P_FIELD,P_FIELD,P_FIELD, APB2F401.18
& TOP_ROW_START,P_BOT_ROW_START, APB2F401.19
& ROW_LENGTH,P_LEVELS) APB2F401.20
APB2F401.21
*ENDIF APB2F401.22
APB2F401.23
! Set up OMEGA_P array APB2F401.24
! (Was SECTION 3.2): APB2F401.25
! SECTION 3.2 INTERPOLATE OMEGA TO P GRID AND CALCULATE APB2F401.26
! REMAINING TERM IN ADVECTION EQUATION. APB2F401.27
! CALCULATE TOTAL MASS-WEIGHTED INCREMENT TO FIELD. APB2F401.28
APB2F401.29
DO K1=1,P_LEVELS APB2F401.30
CALL UV_TO_P(OMEGA(START_U_REQUIRED,K1), APB2F401.31
& OMEGA_P(START_POINT_NO_HALO,K1), APB2F401.32
& U_POINTS_REQUIRED, APB2F401.33
& P_POINTS_UPDATE,ROW_LENGTH,upd_P_ROWS+1) APB2F401.34
*IF DEF,GLOBAL APB2F401.35
! Fujitsu vectorization directive GRB0F405.98
!OCL NOVREC GRB0F405.99
DO I=1,ROW_LENGTH APB2F401.36
OMEGA_P(I,K1)=0. APB2F401.37
OMEGA_P(P_FIELD+1-I,K1)=0. APB2F401.38
ENDDO APB2F401.39
*ENDIF APB2F401.40
ENDDO APB2F401.41
*IF DEF,GLOBAL APB2F401.42
CALL POLAR(OMEGA_P,OMEGA_P,OMEGA_P, APB2F401.43
*CALL ARGFLDPT APB2F401.44
& P_FIELD,P_FIELD,P_FIELD, APB2F401.45
& START_POINT_NO_HALO, APB2F401.46
& END_P_POINT_NO_HALO-ROW_LENGTH+1, APB2F401.47
& ROW_LENGTH,P_LEVELS) APB2F401.48
*ENDIF APB2F401.49
CL BEGIN CONDITIONAL ON LEVEL BEING GREATER THAN 1 THADV1A.463
DO K=1,P_LEVELS+1 ATD1F400.935
IF(K.GT.1) THEN ATD1F400.936
CL--------------------------------------------------------------------- THADV1A.465
CL SECTION 3. ALL WORK IN THIS SECTION PERFORMED AT LEVEL-1. THADV1A.466
CL CALCULATE SECOND INCREMENT DUE TO ADVECTION. THADV1A.467
CL CALCULATE TOTAL INCREMENT TO FIELD AND FILTER THADV1A.468
CL WHERE NECESSARY THEN UPDATE FIELD. THADV1A.469
CL THE POLAR INCREMENTS ARE THEN CALCULATED AND ADDED THADV1A.470
CL ON BY CALLING POLAR. THADV1A.471
CL--------------------------------------------------------------------- THADV1A.472
CL RESET TIMESTEP APPROPRIATE TO LEVEL THADV1A.473
THADV1A.474
TIMESTEP = ADVECTION_TIMESTEP THADV1A.475
THADV1A.479
CONST1 = R/(CP*CP)*TIMESTEP THADV1A.480
C --------------------------------------------------------------------- THADV1A.481
CL SECTION 3.1 CALL ADV_P_GD TO OBTAIN SECOND INCREMENT DUE TO THADV1A.482
CL ADVECTION. THADV1A.483
C --------------------------------------------------------------------- THADV1A.484
THADV1A.485
CL CALL ADV_P_GD FOR THETAL. THADV1A.486
K1=K-1 THADV1A.487
C K1 HOLDS K-1. THADV1A.488
IF(K.GT.P_LEVELS) THEN THADV1A.489
C THE ZERO VERTICAL FLUX AT THE TOP IS ENSURED BY PASSING ETADOT AS THADV1A.490
C ZERO. THADV1A.491
THADV1A.492
CALL ADV_P_GD(THETAL_PROV(1,K-2),THETAL_PROV(1,K-1), AAD2F304.410
* THETAL_PROV(1,K-2), AAD2F304.411
* U_MEAN(1,K1),V_MEAN(1,K1),ETADOT_MEAN(1,K-1), AAD2F304.412
* ZERO,SEC_P_LATITUDE, AAD2F304.413
* THETAL_SECOND_INC,NUX(1,K-1),NUY(1,K-1),P_FIELD, AAD2F304.414
* U_FIELD,ROW_LENGTH, APB0F401.1200
*CALL ARGFLDPT APB0F401.1201
& TIMESTEP,LATITUDE_STEP_INVERSE, THADV1A.497
* LONGITUDE_STEP_INVERSE,SEC_U_LATITUDE, THADV1A.498
* BRSP(1,K-1),L_SECOND,LWHITBROM) AAD2F304.415
THADV1A.501
ELSE IF(K.EQ.2) THEN AAD2F304.416
C THE ZERO VERTICAL FLUX AT THE BOTTOM IS ENSURED BY PASSING ETADOT AS AAD2F304.417
C ZERO. AAD2F304.418
CALL ADV_P_GD(THETAL_PROV(1,K),THETAL_PROV(1,K-1), AAD2F304.419
* THETAL_PROV(1,K), AAD2F304.420
* U_MEAN(1,K1),V_MEAN(1,K1),ZERO, AAD2F304.421
* ETADOT_MEAN(1,K), AAD2F304.422
* SEC_P_LATITUDE,THETAL_SECOND_INC, AAD2F304.423
* NUX(1,K-1),NUY(1,K-1), AAD2F304.424
* P_FIELD,U_FIELD,ROW_LENGTH, THADV1A.505
*CALL ARGFLDPT APB0F401.1202
& TIMESTEP, APB0F401.1203
* LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, THADV1A.507
* SEC_U_LATITUDE, THADV1A.508
* BRSP(1,K-1),L_SECOND,LWHITBROM) AAD2F304.425
ELSE AAD2F304.426
THADV1A.510
CALL ADV_P_GD(THETAL_PROV(1,K-2),THETAL_PROV(1,K-1), AAD2F304.427
* THETAL_PROV(1,K), AAD2F304.428
* U_MEAN(1,K1),V_MEAN(1,K1),ETADOT_MEAN(1,K-1), AAD2F304.429
* ETADOT_MEAN(1,K), AAD2F304.430
* SEC_P_LATITUDE,THETAL_SECOND_INC, AAD2F304.431
* NUX(1,K-1),NUY(1,K-1), AAD2F304.432
* P_FIELD,U_FIELD,ROW_LENGTH, AAD2F304.433
*CALL ARGFLDPT APB0F401.1204
& TIMESTEP, APB0F401.1205
* LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AAD2F304.435
* SEC_U_LATITUDE, AAD2F304.436
* BRSP(1,K-1),L_SECOND,LWHITBROM) AAD2F304.437
END IF THADV1A.511
THADV1A.512
THADV1A.513
C TOTAL MASS-WEIGHTED HORIZONTAL AND VERTICAL INCREMENTS ARE CALCULATED THADV1A.535
C SEPARATELY. THADV1A.536
THADV1A.537
IF(K.LT.Q_LEVELS+2) THEN THADV1A.538
! Loop over field, missing top and bottom rows APB0F401.1206
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1207
THADV1A.540
PK = AKH(K) + BKH(K) *PSTAR(I) THADV1A.541
PK1 = AKH(K1) + BKH(K1)*PSTAR(I) ! K1 = K-1 THADV1A.542
P_EXNER_FULL = P_EXNER_C THADV1A.543
* (P_EXNER(I,K),P_EXNER(I,K1),PK,PK1,KAPPA) THADV1A.544
THADV1A.545
THETAL_INCREMENT(I,K1) = .5*(THETAL_SECOND_INC(I) + THADV1A.546
* THETAL_FIRST_INC(I,K-1)*RS(I,K1)*RS(I,K1) AAD2F304.438
* *(DELTA_AK(K1)+DELTA_BK(K1)*PSTAR(I))) THADV1A.548
* -(LC*QCL(I,K1)+LC_LF*QCF(I,K1))*CONST1* THADV1A.549
& OMEGA_P(I,K1)/((AK(K1)+BK(K1)*PSTAR(I)) APB2F401.50
* *(P_EXNER_FULL)) THADV1A.551
THADV1A.552
END DO ATD1F400.938
ELSE THADV1A.554
! Loop over field, missing top and bottom rows APB0F401.1208
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1209
THETAL_INCREMENT(I,K1) = .5*(THETAL_SECOND_INC(I) + THADV1A.556
* THETAL_FIRST_INC(I,K-1)*RS(I,K1)*RS(I,K1) AAD2F304.439
* *(DELTA_AK(K1)+DELTA_BK(K1)*PSTAR(I))) THADV1A.558
END DO ATD1F400.940
END IF THADV1A.560
THADV1A.561
C --------------------------------------------------------------------- THADV1A.562
CL SECTION 3.3 IF GLOBAL MODEL CALCULATE POLAR INCREMENTS. THADV1A.563
CL IF LIMITED AREA MASS-WEIGHT BOUNDARIES. THADV1A.564
C --------------------------------------------------------------------- THADV1A.565
THADV1A.566
CL GLOBAL MODEL CALCULATE POLAR INCREMENT. THADV1A.567
CL CALCULATE MERIDIONAL FLUX AROUND POLES BY ADDING THE TWO THADV1A.568
CL INCREMENTS AND ALSO MASS-WEIGHTING POLAR FIELDS. THADV1A.569
C NEGATIVE SIGN BEFORE FIRST INCS IS DUE TO THEIR SIGN HAVING BEEN THADV1A.570
C CHANGED PRIOR TO THE CALCULATION OF THE INTERMEDIATE VALUE. THADV1A.571
IF(K.LT.Q_LEVELS+2) THEN THADV1A.572
! Fujitsu vectorization directive GRB0F405.100
!OCL NOVREC GRB0F405.101
DO I=1,ROW_LENGTH ATD1F400.941
C NORTH POLE OR NORTHERN BOUNDARY. THADV1A.574
IK = P_FIELD - ROW_LENGTH + I THADV1A.575
SCALAR1 = RS(I,K1)*RS(I,K1) THADV1A.576
* *(DELTA_AK(K1)+DELTA_BK(K1)*PSTAR(I)) THADV1A.577
*IF DEF,GLOBAL THADV1A.578
THADV1A.579
PK = AKH(K) + BKH(K) *PSTAR(I) THADV1A.580
PK1 = AKH(K1) + BKH(K1)*PSTAR(I) ! K1 = K-1 THADV1A.581
P_EXNER_FULL = P_EXNER_C THADV1A.582
* (P_EXNER(I,K),P_EXNER(I,K1),PK,PK1,KAPPA) THADV1A.583
THADV1A.584
THETAL_INCREMENT(I,K1) = -.5*(THETAL_SECOND_INC(I) THADV1A.585
* - THETAL_FIRST_INC(I,K-1)*SCALAR1) AAD2F304.440
* +(LC*QCL(I,K1)+LC_LF*QCF(I,K1))*CONST1* THADV1A.587
& OMEGA_P(I,K1)/((AK(K1)+BK(K1)*PSTAR(I)) APB2F401.51
* *P_EXNER_FULL) THADV1A.589
*ENDIF THADV1A.590
THETAL(I,K1) = THETAL(I,K1)*SCALAR1 THADV1A.591
C SOUTH POLE OR SOUTHERN BOUNDARY. THADV1A.592
SCALAR2 = RS(IK,K1)*RS(IK,K1) THADV1A.593
* *(DELTA_AK(K1)+DELTA_BK(K1)*PSTAR(IK)) THADV1A.594
*IF DEF,GLOBAL THADV1A.595
THADV1A.596
PK = AKH(K) + BKH(K) *PSTAR(IK) APB0F400.3
PK1 = AKH(K1) + BKH(K1)*PSTAR(IK) ! K1 = K-1 APB0F400.4
P_EXNER_FULL = P_EXNER_C APB0F400.5
& (P_EXNER(IK,K),P_EXNER(IK,K1),PK,PK1,KAPPA) APB0F400.6
THADV1A.601
THETAL_INCREMENT(IK,K1) = -.5*(THETAL_SECOND_INC(IK) THADV1A.602
* - THETAL_FIRST_INC(IK,K-1)*SCALAR2) AAD2F304.441
* +(LC*QCL(IK,K1)+LC_LF*QCF(IK,K1))*CONST1* THADV1A.604
* OMEGA_P(IK,K1)/((AK(K1)+BK(K1)*PSTAR(IK)) APB2F401.52
* *P_EXNER_FULL) THADV1A.606
*ENDIF THADV1A.607
THETAL(IK,K1) = THETAL(IK,K1)*SCALAR2 THADV1A.608
END DO ATD1F400.942
ELSE THADV1A.610
! Fujitsu vectorization directive GRB0F405.102
!OCL NOVREC GRB0F405.103
DO I=1,ROW_LENGTH ATD1F400.943
C NORTH POLE OR NORTHERN BOUNDARY. THADV1A.612
IK = P_FIELD - ROW_LENGTH + I THADV1A.613
SCALAR1 = RS(I,K1)*RS(I,K1) THADV1A.614
* *(DELTA_AK(K1)+DELTA_BK(K1)*PSTAR(I)) THADV1A.615
*IF DEF,GLOBAL THADV1A.616
THETAL_INCREMENT(I,K1) = -.5*(THETAL_SECOND_INC(I) THADV1A.617
* - THETAL_FIRST_INC(I,K-1)*SCALAR1) AAD2F304.442
*ENDIF THADV1A.619
THETAL(I,K1) = THETAL(I,K1)*SCALAR1 THADV1A.620
C SOUTH POLE OR SOUTHERN BOUNDARY. THADV1A.621
SCALAR2 = RS(IK,K1)*RS(IK,K1) THADV1A.622
* *(DELTA_AK(K1)+DELTA_BK(K1)*PSTAR(IK)) THADV1A.623
*IF DEF,GLOBAL THADV1A.624
THETAL_INCREMENT(IK,K1) = -.5*(THETAL_SECOND_INC(IK) THADV1A.625
* - THETAL_FIRST_INC(IK,K-1)*SCALAR2) AAD2F304.443
*ENDIF THADV1A.627
THETAL(IK,K1) = THETAL(IK,K1)*SCALAR2 THADV1A.628
END DO ATD1F400.944
ENDIF THADV1A.630
CL END CONDITIONAL LEVEL GREATER THAN ONE THADV1A.631
END IF THADV1A.632
THADV1A.633
CL END LOOP OVER P_LEVELS+1 THADV1A.634
enddo AAD2F304.444
THADV1A.636
CL--------------------------------------------------------------------- THADV1A.637
CL SECTION 4 IF GLOBAL MODEL THEN FILTER INCREMENTS AND THADV1A.638
CL UPDATE POLAR VALUES BY CALLING POLAR. THADV1A.639
CL UPDATE ALL OTHER VALUES. THADV1A.640
CL--------------------------------------------------------------------- THADV1A.641
THADV1A.642
*IF DEF,GLOBAL THADV1A.643
THADV1A.644
C --------------------------------------------------------------------- THADV1A.645
CL SECTION 4.1 CALL FILTER TO DO FILTERING. THADV1A.646
C --------------------------------------------------------------------- THADV1A.647
THADV1A.648
C SET FILTER_SPACE WHICH IS ROW_LENGTH+2 TIMES THE NUMBER OF ROWS TO THADV1A.649
C BE FILTERED. THADV1A.650
THADV1A.651
FILTER_SPACE = (ROW_LENGTH+2)*(NORTHERN_FILTERED_P_ROW-1+ THADV1A.652
* P_FIELD/ROW_LENGTH-SOUTHERN_FILTERED_P_ROW) THADV1A.653
CL CALL FILTER FOR THETAL INCREMENTS THADV1A.654
THADV1A.655
CALL FILTER(THETAL_INCREMENT,P_FIELD,P_LEVELS, APB0F402.38
& FILTER_SPACE,ROW_LENGTH, APB0F402.39
*CALL ARGFLDPT APB0F402.40
& FILTER_WAVE_NUMBER_P_ROWS,TRIGS,IFAX, APB0F402.41
* NORTHERN_FILTERED_P_ROW,SOUTHERN_FILTERED_P_ROW) THADV1A.659
THADV1A.660
C --------------------------------------------------------------------- THADV1A.661
CL SECTION 4.2 CALL POLAR TO UPDATE POLAR VALUES THADV1A.662
C --------------------------------------------------------------------- THADV1A.663
THADV1A.664
CALL POLAR(THETAL,THETAL_INCREMENT,THETAL_INCREMENT, APB2F401.53
*CALL ARGFLDPT APB2F401.54
& P_FIELD,P_FIELD,P_FIELD, APB2F401.55
& TOP_ROW_START,P_BOT_ROW_START, APB2F401.56
& ROW_LENGTH,P_LEVELS) APB2F401.57
THADV1A.670
*ENDIF THADV1A.671
C --------------------------------------------------------------------- THADV1A.672
CL SECTION 4.3 UPDATE ALL OTHER POINTS. THADV1A.673
C OUTPUT IS MASS-WEIGHTED. ATD1F400.948
C INCREMENTS ARE ALREADY MASS-WEIGHTED ATD1F400.949
C --------------------------------------------------------------------- THADV1A.674
THADV1A.675
DO K=1,P_LEVELS ATD1F400.950
C UPDATE THETAL. THADV1A.677
CFPP$ SELECT(CONCUR) THADV1A.678
! Loop over field, missing top and bottom rows APB0F401.1210
DO I= START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1211
THETAL(I,K)=THETAL(I,K)*RS(I,K)*RS(I,K)* ATD1F400.952
& (DELTA_AK(K)+DELTA_BK(K)*PSTAR(I))-THETAL_INCREMENT(I,K) ATD1F400.953
END DO ATD1F400.954
END DO THADV1A.702
THADV1A.703
CL END OF ROUTINE TH_ADV THADV1A.704
THADV1A.705
RETURN THADV1A.706
END THADV1A.707
*ENDIF THADV1A.708