*IF DEF,A12_1E ADVCTL1E.2
C ******************************COPYRIGHT****************************** ADVCTL1E.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. ADVCTL1E.4
C ADVCTL1E.5
C Use, duplication or disclosure of this code is subject to the ADVCTL1E.6
C restrictions as set forth in the contract. ADVCTL1E.7
C ADVCTL1E.8
C Meteorological Office ADVCTL1E.9
C London Road ADVCTL1E.10
C BRACKNELL ADVCTL1E.11
C Berkshire UK ADVCTL1E.12
C RG12 2SZ ADVCTL1E.13
C ADVCTL1E.14
C If no contract has been raised with this copy of the code, the use, ADVCTL1E.15
C duplication or disclosure of it is strictly prohibited. Permission ADVCTL1E.16
C to do so must first be obtained in writing from the Head of Numerical ADVCTL1E.17
C Modelling at the above address. ADVCTL1E.18
C ******************************COPYRIGHT****************************** ADVCTL1E.19
C ADVCTL1E.20
CLL SUBROUTINE ADV_CTL -------------------------------------------- ADVCTL1E.21
CLL ADVCTL1E.22
CLL PURPOSE: CALCULATES THE RIGHT-HAND SIDES OF EQUATIONS (40) TO ADVCTL1E.23
CLL (42) REPRESENTING THE MASS WEIGHTED FIELDS AFTER ADVCTL1E.24
CLL ADVECTION AND THE ADDITION OF THE CORIOLIS TERM DUE ADVCTL1E.25
CLL TO VERTICAL MOTION. THE SPATIAL DIFFERENCING SCHEME ADVCTL1E.26
CLL (35) TO (38) IS USED. ONE MORE PRESSURE ROW THAN ADVCTL1E.27
CLL VELOCITY ROW IS UPDATED. DIVERGENCE DAMPS VELOCITY ADVCTL1E.28
CLL FIELDS AS DESCRIBED IN SECTION 3.4 OF DOCUMENTATION ADVCTL1E.29
CLL PAPER NO. 10 ADVCTL1E.30
CLL NOT SUITABLE FOR SINGLE COLUMN USE. ADVCTL1E.31
CLL WAS VERSION FOR CRAY Y-MP ADVCTL1E.32
CLL ADVCTL1E.33
CLL WRITTEN BY M.H MAWSON. ADVCTL1E.34
CLL ADVCTL1E.35
CLL MODEL MODIFICATION HISTORY: ADVCTL1E.36
CLL VERSION DATE ADVCTL1E.37
!LL 4.4 11/08/97 New version optimised for T3E. ADVCTL1E.38
!LL Required for new interface to THQADV ADVCTL1E.39
!LL Version 1E not bit reprod with 1C ADVCTL1E.40
CLL 4.4 04/08/97 Optimisation for T3E D.Salmond ADVCTL1E.41
CLL ADVCTL1E.42
CLL ADVCTL1E.43
CLL ADVCTL1E.44
CLL PROGRAMMING STANDARD: ADVCTL1E.45
CLL ADVCTL1E.46
CLL LOGIACL COMPONENTS COVERED: P12 ADVCTL1E.47
CLL ADVCTL1E.48
CLL PROJECT TASK: P1 ADVCTL1E.49
CLL ADVCTL1E.50
CLL DOCUMENTATION: THE EQUATIONS USED ARE (35) TO (46) AND ADVCTL1E.51
CLL SECTION 3.4 IN UNIFIED MODEL DOCUMENTATION ADVCTL1E.52
CLL NO. 10 M.J.P. CULLEN, T.DAVIES AND ADVCTL1E.53
CLL M.H. MAWSON VERSION 17, DATED 11/02/91. ADVCTL1E.54
CLLEND------------------------------------------------------------- ADVCTL1E.55
C*L ARGUMENTS:--------------------------------------------------- ADVCTL1E.56
SUBROUTINE ADV_CTL 2,37ADVCTL1E.57
1 (THETAL,QT,PSTAR_OLD,PSTAR,U_MEAN,V_MEAN,U,V, ADVCTL1E.58
& COS_U_LATITUDE,COS_P_LATITUDE, ADVCTL1E.59
2 SEC_P_LATITUDE,ETADOT_MEAN,RS,DELTA_AK,DELTA_BK, ADVCTL1E.60
3 LATITUDE_STEP_INVERSE,ADVECTION_TIMESTEP,NU_BASIC, ADVCTL1E.61
4 LONGITUDE_STEP_INVERSE,NORTHERN_FILTERED_P_ROW, ADVCTL1E.62
5 SOUTHERN_FILTERED_P_ROW,Q_LEVELS, ADVCTL1E.63
6 U_FIELD,P_FIELD,ROW_LENGTH, ADVCTL1E.64
*CALL ARGFLDPT 
ADVCTL1E.65
7 P_LEVELS,SEC_U_LATITUDE,F1,F2,AK,BK,KD,AKH,BKH, ADVCTL1E.66
8 COS_U_LONGITUDE,SIN_U_LONGITUDE,TRIGS,IFAX, ADVCTL1E.67
9 FILTER_WAVE_NUMBER_P_ROWS,OMEGA,QCL,QCF,P_EXNER, ADVCTL1E.68
& LLINTS,LWHITBROM, ADVCTL1E.69
& L_TRACER_THETAL_QT,NSWEEP,L_SUPERBEE) ADVCTL1E.70
ADVCTL1E.71
IMPLICIT NONE ADVCTL1E.72
ADVCTL1E.73
! All TYPFLDPT arguments are intent IN ADVCTL1E.74
*CALL TYPFLDPT ADVCTL1E.75
*CALL PARVARS ADVCTL1E.76
ADVCTL1E.77
INTEGER ADVCTL1E.78
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. ADVCTL1E.79
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID ADVCTL1E.80
*, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. ADVCTL1E.81
*, Q_LEVELS !IN NUMBER OF MOIST LEVELS. ADVCTL1E.82
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW ADVCTL1E.83
*, NORTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STOPS ADVCTL1E.84
* ! MOVING TOWARDS THE EQUATOR. ADVCTL1E.85
*, SOUTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STARTS AGAIN. ADVCTL1E.86
* ! MOVING TOWARDS SOUTHPOLE. ADVCTL1E.87
*, IFAX(10) !IN HOLDS FACTORS OF ROW_LENGTH USED BY ADVCTL1E.88
* ! FILTERING. ADVCTL1E.89
*IF DEF,MPP ADVCTL1E.90
*, NSWEEP(glsize(2),P_LEVELS) !IN No.of EW sweeps for all rows. ADVCTL1E.91
*ELSE ADVCTL1E.92
*, NSWEEP(P_FIELD/ROW_LENGTH,P_LEVELS) !IN ADVCTL1E.93
*ENDIF ADVCTL1E.94
* ! NUMBER OF EAST_WEST TIMESTEPS NEEDED FOR ADVCTL1E.95
* ! EACH LATITUDE WHEN USING TRACER ADVECTION. ADVCTL1E.96
*, FIRST_POINT ! ADVCTL1E.97
*, POINTS ! ADVCTL1E.98
ADVCTL1E.99
INTEGER ADVCTL1E.100
& FILTER_WAVE_NUMBER_P_ROWS(GLOBAL_P_FIELD/GLOBAL_ROW_LENGTH) ADVCTL1E.101
! LAST WAVE NUMBER NOT TO BE CHOPPED ON A P ROW ADVCTL1E.102
LOGICAL ADVCTL1E.103
& L_SUPERBEE ! FORM OF LIMITER USED IN TRACER ADVCTL1E.104
& ! ADVECTION ADVCTL1E.105
& ,L_TRACER_THETAL_QT ! LOGICAL TRUE IF USING TRACER ADVCTL1E.106
& ! ADVECTION FOR THETAL & QT ADVCTL1E.107
INTEGER ADVCTL1E.108
& P_POINTS_UPDATE ADVCTL1E.109
& ,START_U_REQUIRED ADVCTL1E.110
& ,P_POINTS_REQUIRED ADVCTL1E.111
& ,U_POINTS_REQUIRED ADVCTL1E.112
ADVCTL1E.113
& ,LLINTS !Logical switch for linear TS ADVCTL1E.114
& ,LWHITBROM !Log swch for White & Bromley terms ADVCTL1E.115
ADVCTL1E.116
REAL ADVCTL1E.117
* U_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED U VELOCITY ADVCTL1E.118
* ! FROM ADJUSTMENT STEP ADVCTL1E.119
*,V_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED V VELOCITY ADVCTL1E.120
* ! * COS(LAT) FROM ADJUSTMENT STEP ADVCTL1E.121
*,ETADOT_MEAN(P_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED ADVCTL1E.122
* !VERTICAL VELOCITY FROM ADJUSTMENT STEP ADVCTL1E.123
*,PSTAR(P_FIELD) !IN PSTAR FIELD AT NEW TIME-LEVEL ADVCTL1E.124
*,PSTAR_OLD(P_FIELD) !IN PSTAR AT PREVIOUS TIME-LEVEL ADVCTL1E.125
*,RS(P_FIELD,P_LEVELS) !IN RS FIELD ADVCTL1E.126
*,TRIGS(ROW_LENGTH) !IN HOLDS TRIGONOMETRIC FUNCTIONS USED ADVCTL1E.127
* ! IN FILTERING. ADVCTL1E.128
*,QCL(P_FIELD,Q_LEVELS) !IN. PRIMARY ARRAY FOR QCL. ADVCTL1E.129
*,QCF(P_FIELD,Q_LEVELS) !IN. PRIMARY ARRAY FOR QCF. ADVCTL1E.130
*,P_EXNER(P_FIELD,P_LEVELS+1) !IN. PRIMARY ARRAY FOR P_EXNER. ADVCTL1E.131
ADVCTL1E.132
REAL ADVCTL1E.133
* U(U_FIELD,P_LEVELS) !INOUT U FIELD, MASS-WEIGHTED ON OUT. ADVCTL1E.134
*,V(U_FIELD,P_LEVELS) !INOUT V FIELD, MASS-WEIGHTED ON OUT. ADVCTL1E.135
*,THETAL(P_FIELD,P_LEVELS) !INOUT THETAL FIELD ADVCTL1E.136
*,QT(P_FIELD,Q_LEVELS) !INOUT QT FIELD. ADVCTL1E.137
ADVCTL1E.138
REAL ADVCTL1E.139
* DELTA_AK(P_LEVELS) !IN LAYER THICKNESS ADVCTL1E.140
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS ADVCTL1E.141
*,AK(P_LEVELS) !IN FIRST TERM IN HYBRID CO-ORDS. ADVCTL1E.142
*,BK(P_LEVELS) !IN SECOND TERM IN HYBRID CO-ORDS. ADVCTL1E.143
*,AKH(P_LEVELS+1) !IN AK AT HALF LEVELS ADVCTL1E.144
*,BKH(P_LEVELS+1) !IN BK AT HALF LEVELS ADVCTL1E.145
&,COS_P_LATITUDE(P_FIELD) !IN COS_LAT AT P_POINTS (2D ARRAY) ADVCTL1E.146
*,SEC_P_LATITUDE(P_FIELD) !IN 1/COS(LAT) AT P POINTS (2-D ARRAY) ADVCTL1E.147
*,COS_U_LATITUDE(U_FIELD) !IN COS(LAT) AT U POINTS (2-D ARRAY) ADVCTL1E.148
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) ADVCTL1E.149
*,COS_U_LONGITUDE(ROW_LENGTH) !IN COS(LONGITUDE) AT U-POINTS. ADVCTL1E.150
*,SIN_U_LONGITUDE(ROW_LENGTH) !IN SIN(LONGITUDE) AT U-POINTS. ADVCTL1E.151
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) ADVCTL1E.152
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) ADVCTL1E.153
*,ADVECTION_TIMESTEP !IN ADVCTL1E.154
*,NU_BASIC !IN STANDARD NU TERM FOR MODEL RUN. ADVCTL1E.155
*,F1(U_FIELD) !IN A CORIOLIS TERM SEE DOCUMENTATION ADVCTL1E.156
*,F2(U_FIELD) !IN A CORIOLIS TERM SEE DOCUMENTATION ADVCTL1E.157
*,KD(P_LEVELS) !IN DIVERGENCE DAMPING COEFFICIENTS ADVCTL1E.158
ADVCTL1E.159
REAL ADVCTL1E.160
* OMEGA(U_FIELD,P_LEVELS) !OUT TRUE VERTICAL VELOCITY ADVCTL1E.161
C*--------------------------------------------------------------------- ADVCTL1E.162
ADVCTL1E.163
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- ADVCTL1E.164
C DEFINE LOCAL ARRAYS: 3 ARE REQUIRED ADVCTL1E.165
REAL ADVCTL1E.166
* WORK1(U_FIELD) ! GENERAL WORKSPACE ADVCTL1E.167
*,WORK2(P_FIELD) ! GENERAL WORKSPACE ADVCTL1E.168
&, OMEGA_P(P_FIELD) ! HOLDS OMEGA AT P POINTS. ADVCTL1E.169
ADVCTL1E.170
C*--------------------------------------------------------------------- ADVCTL1E.171
C DEFINE LOCAL VARIABLES ADVCTL1E.172
ADVCTL1E.173
C COUNT VARIABLES FOR DO LOOPS ETC. ADVCTL1E.174
INTEGER ADVCTL1E.175
& I,K,K1 ADVCTL1E.176
ADVCTL1E.177
INTEGER X_FIELD ! 1 IF 2ND ORDER ELSE U_FIELD IF 4TH ORDER ADVCTL1E.178
ADVCTL1E.179
C REAL SCALARS ADVCTL1E.180
REAL ADVCTL1E.181
& CONST1,LC_LF,TIMESTEP ADVCTL1E.182
& ,PK, PK1 ! Pressure at half levels ADVCTL1E.183
& ,P_EXNER_FULL ! Exner pressure at full model level ADVCTL1E.184
ADVCTL1E.185
C LOGICAL VARIABLE ADVCTL1E.186
LOGICAL ADVCTL1E.187
* L_SECOND ! SET TO TRUE IF NU_BASIC EQUAL TO ZERO ADVCTL1E.188
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- ADVCTL1E.189
EXTERNAL TH_Q_ADV,UV_ADV,P_TO_UV,DIV_DAMP ADVCTL1E.190
& ,TRAC_ADV,TRAC_VERT_ADV,UV_TO_P,POLAR ADVCTL1E.191
C*--------------------------------------------------------------------- ADVCTL1E.192
ADVCTL1E.193
*IF DEF,MPP ADVCTL1E.194
INTEGER extended_address(P_FIELD) ADVCTL1E.195
*ENDIF ADVCTL1E.196
ADVCTL1E.197
*CALL C_THADV ADVCTL1E.198
*CALL P_EXNERC ADVCTL1E.199
ADVCTL1E.200
ADVCTL1E.201
*IF DEF,MPP ADVCTL1E.202
IF (NU_BASIC .NE. 0.0) THEN ADVCTL1E.203
! Calculate the mapping between points on the normal horizontal ADVCTL1E.204
! field, and points in the extended field (with double halos for ADVCTL1E.205
! the fourth order code) ADVCTL1E.206
! Logic: extended_address=old_address ADVCTL1E.207
! + ROW_LENGTH*extra_NS_Halo ADVCTL1E.208
! -> extra halo row at top of field ADVCTL1E.209
! + (row_number+1)*2*extra_EW_Halo ADVCTL1E.210
! -> two extra halo points for each preceeding row ADVCTL1E.211
! + extra_EW_Halo -> extra halo point at start of this row ADVCTL1E.212
DO I=FIRST_VALID_PT,LAST_P_VALID_PT ADVCTL1E.213
extended_address(I)=I + ROW_LENGTH*extra_NS_Halo + ADVCTL1E.214
& (((I-1)/ROW_LENGTH)+extra_NS_Halo)*2*extra_EW_Halo + ADVCTL1E.215
& extra_EW_Halo ADVCTL1E.216
ENDDO ADVCTL1E.217
ENDIF ADVCTL1E.218
*ENDIF ADVCTL1E.219
CL MAXIMUM VECTOR LENGTH ASSUMED IS U_FIELD. ADVCTL1E.220
CL--------------------------------------------------------------------- ADVCTL1E.221
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: ADVCTL1E.222
CL--------------------------------------------------------------------- ADVCTL1E.223
CL ADVCTL1E.224
C**************************************************************** ADVCTL1E.225
C INTEGERS AND VARIABLES NEEDED WHEN USING ADVCTL1E.226
C TRACER ADVECTION OF THETAL & QT ADVCTL1E.227
C***************************************************************** ADVCTL1E.228
IF(L_TRACER_THETAL_QT)THEN ADVCTL1E.229
LC_LF=LC + LF ADVCTL1E.230
P_POINTS_UPDATE=upd_P_ROWS*ROW_LENGTH ADVCTL1E.231
START_U_REQUIRED = START_POINT_NO_HALO-ROW_LENGTH ADVCTL1E.232
P_POINTS_REQUIRED = (upd_P_ROWS+2)*ROW_LENGTH ADVCTL1E.233
U_POINTS_REQUIRED = (upd_U_ROWS+2)*ROW_LENGTH ADVCTL1E.234
ENDIF ADVCTL1E.235
CL--------------------------------------------------------------------- ADVCTL1E.236
CL SECTION 1. INTERPOLATE FIELDS ONTO U GRID. ADVCTL1E.237
CL--------------------------------------------------------------------- ADVCTL1E.238
ADVCTL1E.239
IF(NU_BASIC.EQ.0.) THEN ADVCTL1E.240
L_SECOND=.TRUE. ADVCTL1E.241
X_FIELD=1 ADVCTL1E.242
ELSE ADVCTL1E.243
L_SECOND=.FALSE. ADVCTL1E.244
X_FIELD=U_FIELD ADVCTL1E.245
END IF ADVCTL1E.246
*IF DEF,MPP ADVCTL1E.247
! Initialise arrays WORK1 & WORK2 ADVCTL1E.248
DO I = 1,P_FIELD ADVCTL1E.249
WORK1(I) = 1.0 ADVCTL1E.250
WORK2(I) = 1.0 ADVCTL1E.251
END DO ADVCTL1E.252
*ENDIF ADVCTL1E.253
ADVCTL1E.254
C---------------------------------------------------------------------- ADVCTL1E.255
CL SECTION 1.1 INTERPOLATE PSTAR ONTO U GRID. ADVCTL1E.256
C---------------------------------------------------------------------- ADVCTL1E.257
ADVCTL1E.258
CALL P_TO_UV(PSTAR,WORK1,P_FIELD,U_FIELD,ROW_LENGTH,tot_P_ROWS) ADVCTL1E.259
ADVCTL1E.260
C---------------------------------------------------------------------- ADVCTL1E.261
CL SECTION 1.2 INTERPOLATE PSTAR_OLD ONTO U GRID. ADVCTL1E.262
C---------------------------------------------------------------------- ADVCTL1E.263
ADVCTL1E.264
CALL P_TO_UV(PSTAR_OLD,WORK2,P_FIELD,U_FIELD,ROW_LENGTH, ADVCTL1E.265
& tot_P_ROWS) ADVCTL1E.266
ADVCTL1E.267
*IF DEF,MPP ADVCTL1E.268
! Update the halos of WORK1 and WORK2 ADVCTL1E.269
CALL SWAPBOUNDS(WORK1,ROW_LENGTH,tot_P_ROWS,EW_Halo,NS_Halo,1) ADVCTL1E.270
CALL SWAPBOUNDS(WORK2,ROW_LENGTH,tot_P_ROWS,EW_Halo,NS_Halo,1) ADVCTL1E.271
*ENDIF ADVCTL1E.272
ADVCTL1E.273
CL ADVCTL1E.274
CL--------------------------------------------------------------------- ADVCTL1E.275
CL SECTION 2. CALL DIV_DAMP TO PERFORM DIVERGENCE DAMPING. ADVCTL1E.276
CL--------------------------------------------------------------------- ADVCTL1E.277
ADVCTL1E.278
C PSTAR_OLD ON U GRID IS HELD IN WORK2. ADVCTL1E.279
ADVCTL1E.280
CALL DIV_DAMP(U,V,RS,SEC_U_LATITUDE,WORK2,COS_U_LATITUDE,KD, ADVCTL1E.281
* LONGITUDE_STEP_INVERSE,LATITUDE_STEP_INVERSE, ADVCTL1E.282
* P_FIELD,U_FIELD,ROW_LENGTH,P_LEVELS, ADVCTL1E.283
*CALL ARGFLDPT ADVCTL1E.284
* BKH,ADVECTION_TIMESTEP,DELTA_AK,DELTA_BK, ADVCTL1E.285
* COS_U_LONGITUDE,SIN_U_LONGITUDE,SEC_P_LATITUDE) ADVCTL1E.286
ADVCTL1E.287
CL ADVCTL1E.288
CL--------------------------------------------------------------------- ADVCTL1E.289
CL SECTION 3. CALL UV_ADV TO ADVECT U AND V. ADVCTL1E.290
CL--------------------------------------------------------------------- ADVCTL1E.291
ADVCTL1E.292
C PSTAR ON U GRID IS HELD IN WORK1. ADVCTL1E.293
C PSTAR_OLD ON U GRID IS HELD IN WORK2. ADVCTL1E.294
ADVCTL1E.295
CALL UV_ADV (U,V,WORK2,WORK1,U_MEAN,V_MEAN, ADVCTL1E.296
* SEC_U_LATITUDE,ETADOT_MEAN,RS,DELTA_AK,DELTA_BK,AK, ADVCTL1E.297
* BK,F1,F2,LATITUDE_STEP_INVERSE,ADVECTION_TIMESTEP, ADVCTL1E.298
* NU_BASIC,LONGITUDE_STEP_INVERSE,U_FIELD,P_FIELD, ADVCTL1E.299
* ROW_LENGTH,P_LEVELS, ADVCTL1E.300
*CALL ARGFLDPT ADVCTL1E.301
* COS_U_LONGITUDE,SIN_U_LONGITUDE,SEC_P_LATITUDE, ADVCTL1E.302
& AKH,BKH,OMEGA,L_SECOND,LLINTS, ADVCTL1E.303
*IF DEF,MPP ADVCTL1E.304
& extended_address, ADVCTL1E.305
*ENDIF ADVCTL1E.306
& LWHITBROM,X_FIELD) ADVCTL1E.307
*IF DEF,MPP ADVCTL1E.308
! Update the halos for the OMEGA array ADVCTL1E.309
CALL SWAPBOUNDS(OMEGA,ROW_LENGTH,tot_P_ROWS, ADVCTL1E.310
& EW_Halo,NS_Halo,P_LEVELS) ADVCTL1E.311
ADVCTL1E.312
! U and V are not swapped here, but in ATM_DYN, after the call to ADVCTL1E.313
! MASS_UWT which spoils the halo. ADVCTL1E.314
ADVCTL1E.315
*ENDIF ADVCTL1E.316
CL ADVCTL1E.317
CL--------------------------------------------------------------------- ADVCTL1E.318
CL SECTION 4. CALL TH_Q_ADV TO ADVECT THETAL AND ADVCTL1E.319
CL QT USING STANDARD HEUN ADVECTION. ADVCTL1E.320
CL IF USING TRACER ADVECTION FOR THETAL & QT ADVCTL1E.321
CL THEN CALL APPROPRIATE TRACER ROUTINES. ADVCTL1E.322
CL--------------------------------------------------------------------- ADVCTL1E.323
IF(.NOT.L_TRACER_THETAL_QT)THEN ADVCTL1E.324
CL--------------------------------------------------------------- ADVCTL1E.325
C SECTION 4.1 HEUN ADVVECTION SCHEME ADVCTL1E.326
C ADVCTL1E.327
CL---------------------------------------------------------------- ADVCTL1E.328
ADVCTL1E.329
CALL TH_Q_ADV (THETAL,QT,PSTAR_OLD,PSTAR,U_MEAN,V_MEAN, ADVCTL1E.330
* SEC_P_LATITUDE, ADVCTL1E.331
* ETADOT_MEAN,RS,DELTA_AK,DELTA_BK,LATITUDE_STEP_INVERSE ADVCTL1E.332
* ,ADVECTION_TIMESTEP,NU_BASIC,LONGITUDE_STEP_INVERSE, ADVCTL1E.333
* NORTHERN_FILTERED_P_ROW,SOUTHERN_FILTERED_P_ROW, ADVCTL1E.334
* P_LEVELS,U_FIELD,P_FIELD,ROW_LENGTH, ADVCTL1E.335
*CALL ARGFLDPT ADVCTL1E.336
* TRIGS,IFAX,FILTER_WAVE_NUMBER_P_ROWS,SEC_U_LATITUDE, ADVCTL1E.337
* AKH,BKH,QCL,QCF,P_EXNER,OMEGA, ADVCTL1E.338
& Q_LEVELS,AK,BK,L_SECOND, ADVCTL1E.339
*IF DEF,MPP ADVCTL1E.340
& extended_address, ADVCTL1E.341
*ENDIF ADVCTL1E.342
& LWHITBROM) ADVCTL1E.343
ADVCTL1E.344
*IF DEF,MPP ADVCTL1E.345
! Update the halos for the THETAL array ADVCTL1E.346
CALL SWAPBOUNDS(THETAL,ROW_LENGTH,tot_P_ROWS, ADVCTL1E.347
& EW_Halo,NS_Halo,P_LEVELS) ADVCTL1E.348
ADVCTL1E.349
! Update the halos for the QT array ADVCTL1E.350
CALL SWAPBOUNDS(QT,ROW_LENGTH,tot_P_ROWS, ADVCTL1E.351
& EW_Halo,NS_Halo,Q_LEVELS) ADVCTL1E.352
*ENDIF ADVCTL1E.353
ELSE ADVCTL1E.354
CL--------------------------------------------------------------- ADVCTL1E.355
C SECTION 4.2 TRACER ADVECTION OF THETAL AND QT ADVCTL1E.356
C ADVCTL1E.357
CL---------------------------------------------------------------- ADVCTL1E.358
DO K=1,P_LEVELS ADVCTL1E.359
CALL TRAC_ADV(THETAL(1,K),NSWEEP(1,K),U_MEAN(1,K),V_MEAN(1,K), ADVCTL1E.360
& U_FIELD,P_FIELD,ADVECTION_TIMESTEP,ROW_LENGTH, ADVCTL1E.361
*CALL ARGFLDPT ADVCTL1E.362
& SEC_P_LATITUDE,COS_P_LATITUDE,RS(1,K), ADVCTL1E.363
& PSTAR_OLD,DELTA_AK(K),DELTA_BK(K), ADVCTL1E.364
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ADVCTL1E.365
& L_SUPERBEE) ADVCTL1E.366
END DO ADVCTL1E.367
ADVCTL1E.368
C Set temperature flux through lower boundary to zero ADVCTL1E.369
DO I=1,P_FIELD ADVCTL1E.370
WORK2(I)=0. ADVCTL1E.371
END DO ADVCTL1E.372
ADVCTL1E.373
*IF DEF,MPP ADVCTL1E.374
FIRST_POINT = START_POINT_NO_HALO ADVCTL1E.375
POINTS = upd_P_ROWS * ROW_LENGTH ADVCTL1E.376
*IF DEF,GLOBAL ADVCTL1E.377
! If processor includes North or South polar row, compute a pt. on it ADVCTL1E.378
IF (at_top_of_LPG) THEN ADVCTL1E.379
FIRST_POINT = FIRST_POINT -Offx -1 ADVCTL1E.380
POINTS = POINTS +Offx +1 ADVCTL1E.381
END IF ADVCTL1E.382
IF (at_base_of_LPG) THEN ADVCTL1E.383
POINTS = POINTS +Offx +1 ADVCTL1E.384
END IF ADVCTL1E.385
*ENDIF ADVCTL1E.386
*ELSE ADVCTL1E.387
*IF DEF,GLOBAL ADVCTL1E.388
FIRST_POINT=ROW_LENGTH ADVCTL1E.389
POINTS = P_FIELD - 2*ROW_LENGTH + 2 ADVCTL1E.390
*ELSE ADVCTL1E.391
FIRST_POINT=ROW_LENGTH+2 ADVCTL1E.392
POINTS = P_FIELD - 2*ROW_LENGTH - 2 ADVCTL1E.393
*ENDIF ADVCTL1E.394
*ENDIF ADVCTL1E.395
ADVCTL1E.396
TIMESTEP=ADVECTION_TIMESTEP ADVCTL1E.397
CONST1=R/(CP*CP)*TIMESTEP ADVCTL1E.398
CALL TRAC_VERT_ADV(THETAL,ETADOT_MEAN,PSTAR,P_FIELD, ADVCTL1E.399
& TIMESTEP,1,P_LEVELS,FIRST_POINT, ADVCTL1E.400
& POINTS,P_LEVELS,1,P_LEVELS,RS,AK,BK,DELTA_AK, ADVCTL1E.401
& DELTA_BK,WORK2,L_TRACER_THETAL_QT,L_SUPERBEE) ADVCTL1E.402
C --------------------------------------------------------------------- ADVCTL1E.403
CL INTERPOLATE OMEGA TO P GRID AND CALCULATE ADVCTL1E.404
CL REMAINING TERM IN ADVECTION EQUATION. ADVCTL1E.405
CL CALCULATE TOTAL MASS-WEIGHTED INCREMENT TO FIELD. ADVCTL1E.406
C --------------------------------------------------------------------- ADVCTL1E.407
ADVCTL1E.408
DO 110 K=1,P_LEVELS ADVCTL1E.409
ADVCTL1E.410
CALL UV_TO_P(OMEGA(START_U_REQUIRED,K), ADVCTL1E.411
& OMEGA_P(START_POINT_NO_HALO),U_POINTS_REQUIRED, ADVCTL1E.412
& P_POINTS_UPDATE,ROW_LENGTH,upd_P_ROWS+1) ADVCTL1E.413
ADVCTL1E.414
*IF DEF,GLOBAL ADVCTL1E.415
DO I = FIRST_VALID_PT,FIRST_VALID_PT+ROW_LENGTH-1 ADVCTL1E.416
OMEGA_P(I)=0. ADVCTL1E.417
END DO ADVCTL1E.418
DO I = LAST_P_VALID_PT-ROW_LENGTH+1,LAST_P_VALID_PT ADVCTL1E.419
OMEGA_P(I)=0. ADVCTL1E.420
END DO ADVCTL1E.421
ADVCTL1E.422
C SET UP POLAR VALUE OF OMEGA ADVCTL1E.423
ADVCTL1E.424
CALL POLAR(OMEGA_P,OMEGA_P,OMEGA_P, ADVCTL1E.425
*CALL ARGFLDPT ADVCTL1E.426
& P_FIELD,P_FIELD,P_FIELD, ADVCTL1E.427
& START_POINT_NO_HALO, ADVCTL1E.428
& END_P_POINT_NO_HALO-ROW_LENGTH+1, ADVCTL1E.429
& ROW_LENGTH,1) ADVCTL1E.430
*ENDIF ADVCTL1E.431
C TOTAL MASS-WEIGHTED HORIZONTAL AND VERTICAL INCREMENTS ARE CALCULATED ADVCTL1E.432
C SEPARATELY. ADVCTL1E.433
ADVCTL1E.434
IF(K.LT.Q_LEVELS+1) THEN ADVCTL1E.435
DO I = FIRST_POINT,FIRST_POINT+POINTS-1 ADVCTL1E.436
ADVCTL1E.437
PK = AKH(K+1)+ BKH(K+1)*PSTAR(I) ADVCTL1E.438
PK1 = AKH(K) + BKH(K)*PSTAR(I) ADVCTL1E.439
P_EXNER_FULL = P_EXNER_C ADVCTL1E.440
& (P_EXNER(I,K+1),P_EXNER(I,K),PK,PK1,KAPPA) ADVCTL1E.441
ADVCTL1E.442
WORK2(I) = ADVCTL1E.443
& -(LC*QCL(I,K)+LC_LF*QCF(I,K))*CONST1* ADVCTL1E.444
& OMEGA_P(I)/((AK(K)+BK(K)*PSTAR(I)) ADVCTL1E.445
& *(P_EXNER_FULL)* ADVCTL1E.446
& RS(I,K)*RS(I,K)*(DELTA_AK(K)+DELTA_BK(K)*PSTAR(I))) ADVCTL1E.447
THETAL(I,K) =THETAL(I,K)+WORK2(I) ADVCTL1E.448
END DO ADVCTL1E.449
END IF ADVCTL1E.450
ADVCTL1E.451
CL END LOOP OVER P_LEVELS+1 ADVCTL1E.452
110 CONTINUE ADVCTL1E.453
ADVCTL1E.454
*IF DEF,GLOBAL ADVCTL1E.455
C Copy polar values along row ADVCTL1E.456
DO K=1,P_LEVELS ADVCTL1E.457
*IF DEF,MPP ADVCTL1E.458
IF (at_top_of_LPG) THEN ADVCTL1E.459
DO I = FIRST_VALID_PT+Offx,START_POINT_NO_HALO-Offx-2 ADVCTL1E.460
THETAL(I,K) = THETAL(START_POINT_NO_HALO-Offx-1,K) ADVCTL1E.461
END DO ADVCTL1E.462
END IF ADVCTL1E.463
IF (at_base_of_LPG) THEN ADVCTL1E.464
DO I = END_P_POINT_NO_HALO+Offx+2,LAST_P_VALID_PT-Offx ADVCTL1E.465
THETAL(I,K) = THETAL(END_P_POINT_NO_HALO+Offx+1,K) ADVCTL1E.466
END DO ADVCTL1E.467
END IF ADVCTL1E.468
*ELSE ADVCTL1E.469
DO I=1,ROW_LENGTH-1 ADVCTL1E.470
THETAL(I,K) = THETAL(ROW_LENGTH,K) ADVCTL1E.471
THETAL(P_FIELD+1-I,K) = THETAL(P_FIELD+1-ROW_LENGTH,K) ADVCTL1E.472
END DO ADVCTL1E.473
*ENDIF ADVCTL1E.474
END DO ADVCTL1E.475
*ENDIF ADVCTL1E.476
*IF DEF,MPP ADVCTL1E.477
! Update the halos for the THETAL array ADVCTL1E.478
CALL SWAPBOUNDS(THETAL,ROW_LENGTH,tot_P_ROWS, ADVCTL1E.479
& EW_Halo,NS_Halo,P_LEVELS) ADVCTL1E.480
ADVCTL1E.481
*ENDIF ADVCTL1E.482
ADVCTL1E.483
DO K=1,Q_LEVELS ADVCTL1E.484
CALL TRAC_ADV(QT(1,K),NSWEEP(1,K),U_MEAN(1,K),V_MEAN(1,K), ADVCTL1E.485
& U_FIELD,P_FIELD,ADVECTION_TIMESTEP,ROW_LENGTH, ADVCTL1E.486
*CALL ARGFLDPT ADVCTL1E.487
& SEC_P_LATITUDE,COS_P_LATITUDE,RS(1,K), ADVCTL1E.488
& PSTAR_OLD,DELTA_AK(K),DELTA_BK(K), ADVCTL1E.489
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ADVCTL1E.490
& L_SUPERBEE) ADVCTL1E.491
END DO ADVCTL1E.492
ADVCTL1E.493
C Set moisture flux through lower boundary to zero ADVCTL1E.494
DO I=1,P_FIELD ADVCTL1E.495
WORK2(I)=0. ADVCTL1E.496
END DO ADVCTL1E.497
ADVCTL1E.498
! Values of FIRST_POINT and POINTS ADVCTL1E.499
! should be unaltered from those set for Thetal ADVCTL1E.500
ADVCTL1E.501
CALL TRAC_VERT_ADV(QT,ETADOT_MEAN,PSTAR,P_FIELD, ADVCTL1E.502
& TIMESTEP,1,Q_LEVELS,FIRST_POINT, ADVCTL1E.503
& POINTS,P_LEVELS,1,Q_LEVELS,RS,AK,BK,DELTA_AK, ADVCTL1E.504
& DELTA_BK,WORK2,L_TRACER_THETAL_QT,L_SUPERBEE) ADVCTL1E.505
ADVCTL1E.506
C END DO ADVCTL1E.507
ADVCTL1E.508
*IF DEF,GLOBAL ADVCTL1E.509
C Copy polar values along row ADVCTL1E.510
DO K=1,Q_LEVELS ADVCTL1E.511
*IF DEF,MPP ADVCTL1E.512
IF (at_top_of_LPG) THEN ADVCTL1E.513
DO I = FIRST_VALID_PT+Offx,START_POINT_NO_HALO-Offx-2 ADVCTL1E.514
QT(I,K) = QT(START_POINT_NO_HALO-Offx-1,K) ADVCTL1E.515
END DO ADVCTL1E.516
END IF ADVCTL1E.517
IF (at_base_of_LPG) THEN ADVCTL1E.518
DO I = END_P_POINT_NO_HALO+Offx+2,LAST_P_VALID_PT-Offx ADVCTL1E.519
QT(I,K) = QT(END_P_POINT_NO_HALO+Offx+1,K) ADVCTL1E.520
END DO ADVCTL1E.521
END IF ADVCTL1E.522
*ELSE ADVCTL1E.523
DO I=1,ROW_LENGTH-1 ADVCTL1E.524
QT(I,K) = QT(ROW_LENGTH,K) ADVCTL1E.525
QT(P_FIELD+1-I,K) = QT(P_FIELD+1-ROW_LENGTH,K) ADVCTL1E.526
END DO ADVCTL1E.527
*ENDIF ADVCTL1E.528
END DO ADVCTL1E.529
*ENDIF ADVCTL1E.530
*IF DEF,MPP ADVCTL1E.531
! Update the halos for the QT array ADVCTL1E.532
CALL SWAPBOUNDS(QT,ROW_LENGTH,tot_P_ROWS, ADVCTL1E.533
& EW_Halo,NS_Halo,Q_LEVELS) ADVCTL1E.534
*ENDIF ADVCTL1E.535
ENDIF ! L_TRACER_THETAL_QT ADVCTL1E.536
ADVCTL1E.537
CL END OF ROUTINE ADV_CTL ADVCTL1E.538
ADVCTL1E.539
RETURN ADVCTL1E.540
END ADVCTL1E.541
*ENDIF ADVCTL1E.542