*IF DEF,A12_1B,OR,DEF,A12_1C,OR,DEF,A12_1D ATJ0F402.10
C ******************************COPYRIGHT****************************** GTS2F400.217
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.218
C GTS2F400.219
C Use, duplication or disclosure of this code is subject to the GTS2F400.220
C restrictions as set forth in the contract. GTS2F400.221
C GTS2F400.222
C Meteorological Office GTS2F400.223
C London Road GTS2F400.224
C BRACKNELL GTS2F400.225
C Berkshire UK GTS2F400.226
C RG12 2SZ GTS2F400.227
C GTS2F400.228
C If no contract has been raised with this copy of the code, the use, GTS2F400.229
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.230
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.231
C Modelling at the above address. GTS2F400.232
C ******************************COPYRIGHT****************************** GTS2F400.233
C GTS2F400.234
CLL SUBROUTINE ADV_CTL -------------------------------------------- ADVCTL1A.3
CLL ADVCTL1A.4
CLL PURPOSE: CALCULATES THE RIGHT-HAND SIDES OF EQUATIONS (40) TO ADVCTL1A.5
CLL (42) REPRESENTING THE MASS WEIGHTED FIELDS AFTER ADVCTL1A.6
CLL ADVECTION AND THE ADDITION OF THE CORIOLIS TERM DUE ADVCTL1A.7
CLL TO VERTICAL MOTION. THE SPATIAL DIFFERENCING SCHEME ADVCTL1A.8
CLL (35) TO (38) IS USED. ONE MORE PRESSURE ROW THAN ADVCTL1A.9
CLL VELOCITY ROW IS UPDATED. DIVERGENCE DAMPS VELOCITY ADVCTL1A.10
CLL FIELDS AS DESCRIBED IN SECTION 3.4 OF DOCUMENTATION ADVCTL1A.11
CLL PAPER NO. 10 ADVCTL1A.12
CLL NOT SUITABLE FOR SINGLE COLUMN USE. ADVCTL1A.13
CLL VERSION FOR CRAY Y-MP ADVCTL1A.14
CLL ADVCTL1A.15
CLL WRITTEN BY M.H MAWSON. ADVCTL1A.16
CLL ADVCTL1A.17
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: ADVCTL1A.18
CLL VERSION DATE ADVCTL1A.19
CLL 3.1 24/02/93 Tidy code to remove QA Fortran messages. MM240293.27
CLL 3.4 22/06/94 Argument LLINTS added and passed to UV_ADV GSS1F304.787
CLL Argument LWHITBROM added and passed to UV_ADV, GSS1F304.788
CLL TH_ADV, QT_ADV GSS1F304.789
CLL S.J.Swarbrick GSS1F304.790
CLL Argument X_FIELD passed to UV_ADV to reduce GSS1F304.791
CLL memory use of new macrotasking. R.Rawlins GSS1F304.792
CLL 4.0 1/4/95 TRACER ADVECTION OF THETAL AND QT INCLUDED AS AN ATD1F400.136
CLL OPTION UNDER THE CONTROL OF LOGICAL L_TRACER_THETAL_QT ATD1F400.137
CLL L_TRACER_THETAL_QT IF SET TO TRUE. ATD1F400.138
CLL CALLS TO TH_ADV AND QT_ADV ARE REPLACED BY ATD1F400.139
CLL CALLS TO TRAC_ADV AND TRAC_VERT_ADV ATD1F400.140
CLL L_HALF_TIMESTEP_TOP REPLACED BY L_TRACER_THETAL_QT. ATD1F400.141
CLL AUTHOR: T. DAVIES, REVIEWER: M. MAWSON ATD1F400.142
! 3.5 28/03/95 MPP code: Modify P_TO_UV calls and APB0F305.489
! add halo updates P.Burton APB0F305.490
! 4.1 22/04/96 Added TYPFLDPT arguments to dynamics routines APB0F401.692
! which allows many of the differences between APB0F401.693
! MPP and "normal" code to be at top level APB0F401.694
! P.Burton APB0F401.695
! 4.2 20/08/96 MPP mods for tracer advection. RTHBarnes. ARB1F402.1
!LL 4.2 16/08/96 Make the FILTER_WAVE_NUMBER arrays globally APB0F402.10
!LL sized P.Burton APB0F402.11
!LL 4.2 25/11/96 Corrections to allow LAM to run in MPP mode. ARB2F402.26
!LL RTHBarnes. ARB2F402.27
!LL 4.3 17/03/97 Make initialisation of OMEGA_P safe for MPP. RTHB. ARB1F403.1
C vn4.3 Mar. 97 T3E migration : optimisation changes GSS1F403.652
C D.Salmond GSS1F403.653
CLL ADVCTL1A.20
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, ADVCTL1A.21
CLL STANDARD B. ADVCTL1A.22
CLL ADVCTL1A.23
CLL LOGIACL COMPONENTS COVERED: P12 ADVCTL1A.24
CLL ADVCTL1A.25
CLL PROJECT TASK: P1 ADVCTL1A.26
CLL ADVCTL1A.27
CLL DOCUMENTATION: THE EQUATIONS USED ARE (35) TO (46) AND ADVCTL1A.28
CLL SECTION 3.4 IN UNIFIED MODEL DOCUMENTATION ADVCTL1A.29
CLL NO. 10 M.J.P. CULLEN, T.DAVIES AND ADVCTL1A.30
CLL M.H. MAWSON VERSION 17, DATED 11/02/91. ADVCTL1A.31
CLLEND------------------------------------------------------------- ADVCTL1A.32
C*L ARGUMENTS:--------------------------------------------------- ADVCTL1A.33
SUBROUTINE ADV_CTL 2,37ADVCTL1A.34
1 (THETAL,QT,PSTAR_OLD,PSTAR,U_MEAN,V_MEAN,U,V, ADVCTL1A.35
& COS_U_LATITUDE,COS_P_LATITUDE, ATD1F400.143
2 SEC_P_LATITUDE,ETADOT_MEAN,RS,DELTA_AK,DELTA_BK, ADVCTL1A.37
3 LATITUDE_STEP_INVERSE,ADVECTION_TIMESTEP,NU_BASIC, ADVCTL1A.38
4 LONGITUDE_STEP_INVERSE,NORTHERN_FILTERED_P_ROW, ADVCTL1A.39
5 SOUTHERN_FILTERED_P_ROW,Q_LEVELS, ADVCTL1A.40
6 U_FIELD,P_FIELD,ROW_LENGTH, APB0F401.696
*CALL ARGFLDPT 
APB0F401.697
7 P_LEVELS,SEC_U_LATITUDE,F1,F2,AK,BK,KD,AKH,BKH, APB0F401.698
8 COS_U_LONGITUDE,SIN_U_LONGITUDE,TRIGS,IFAX, ADVCTL1A.43
9 FILTER_WAVE_NUMBER_P_ROWS,OMEGA,QCL,QCF,P_EXNER, ADVCTL1A.44
& LLINTS,LWHITBROM, ATD1F400.144
& L_TRACER_THETAL_QT,NSWEEP,L_SUPERBEE) ATD1F400.145
ADVCTL1A.46
IMPLICIT NONE ADVCTL1A.47
ADVCTL1A.48
! All TYPFLDPT arguments are intent IN ARB1F402.2
*CALL TYPFLDPT ARB1F402.3
*CALL PARVARS ARB1F402.4
ARB1F402.5
INTEGER ADVCTL1A.49
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. ADVCTL1A.50
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID ADVCTL1A.51
*, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. ADVCTL1A.53
*, Q_LEVELS !IN NUMBER OF MOIST LEVELS. ADVCTL1A.54
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW ADVCTL1A.56
*, NORTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STOPS ADVCTL1A.57
* ! MOVING TOWARDS THE EQUATOR. ADVCTL1A.58
*, SOUTHERN_FILTERED_P_ROW !IN ROW ON WHICH FILTERING STARTS AGAIN. ADVCTL1A.59
* ! MOVING TOWARDS SOUTHPOLE. ADVCTL1A.60
*, IFAX(10) !IN HOLDS FACTORS OF ROW_LENGTH USED BY ADVCTL1A.63
* ! FILTERING. ADVCTL1A.64
*IF DEF,MPP ARB1F402.6
*, NSWEEP(glsize(2),P_LEVELS) !IN No.of EW sweeps for all rows. ARB1F402.7
*ELSE ARB1F402.8
*, NSWEEP(P_FIELD/ROW_LENGTH,P_LEVELS) !IN ATD1F400.146
*ENDIF ARB1F402.9
* ! NUMBER OF EAST_WEST TIMESTEPS NEEDED FOR ATD1F400.147
* ! EACH LATITUDE WHEN USING TRACER ADVECTION. ATD1F400.148
*, FIRST_POINT ! ATD1F400.149
*, POINTS ! ATD1F400.150
APB0F401.699
INTEGER APB0F402.12
& FILTER_WAVE_NUMBER_P_ROWS(GLOBAL_P_FIELD/GLOBAL_ROW_LENGTH) APB0F402.13
! LAST WAVE NUMBER NOT TO BE CHOPPED ON A P ROW APB0F402.14
LOGICAL ADVCTL1A.66
& L_SUPERBEE ! FORM OF LIMITER USED IN TRACER ATD1F400.151
& ! ADVECTION ATD1F400.152
& ,L_TRACER_THETAL_QT ! LOGICAL TRUE IF USING TRACER ATD1F400.153
& ! ADVECTION FOR THETAL & QT ATD1F400.154
INTEGER ATD1F400.155
& P_POINTS_UPDATE ATD1F400.156
& ,START_U_REQUIRED ATD1F400.160
& ,P_POINTS_REQUIRED ATD1F400.161
& ,U_POINTS_REQUIRED ATD1F400.162
ATD1F400.163
& ,LLINTS !Logical switch for linear TS GSS1F304.794
& ,LWHITBROM !Log swch for White & Bromley terms GSS1F304.795
ADVCTL1A.69
REAL ADVCTL1A.70
* U_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED U VELOCITY ADVCTL1A.71
* ! FROM ADJUSTMENT STEP ADVCTL1A.72
*,V_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED V VELOCITY ADVCTL1A.73
* ! * COS(LAT) FROM ADJUSTMENT STEP ADVCTL1A.74
*,ETADOT_MEAN(P_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED ADVCTL1A.75
* !VERTICAL VELOCITY FROM ADJUSTMENT STEP ADVCTL1A.76
*,PSTAR(P_FIELD) !IN PSTAR FIELD AT NEW TIME-LEVEL ADVCTL1A.77
*,PSTAR_OLD(P_FIELD) !IN PSTAR AT PREVIOUS TIME-LEVEL ADVCTL1A.78
*,RS(P_FIELD,P_LEVELS) !IN RS FIELD ADVCTL1A.79
*,TRIGS(ROW_LENGTH) !IN HOLDS TRIGONOMETRIC FUNCTIONS USED ADVCTL1A.80
* ! IN FILTERING. ADVCTL1A.81
*,QCL(P_FIELD,Q_LEVELS) !IN. PRIMARY ARRAY FOR QCL. ADVCTL1A.82
*,QCF(P_FIELD,Q_LEVELS) !IN. PRIMARY ARRAY FOR QCF. ADVCTL1A.83
*,P_EXNER(P_FIELD,P_LEVELS+1) !IN. PRIMARY ARRAY FOR P_EXNER. ADVCTL1A.84
ADVCTL1A.85
REAL ADVCTL1A.86
* U(U_FIELD,P_LEVELS) !INOUT U FIELD, MASS-WEIGHTED ON OUT. ADVCTL1A.87
*,V(U_FIELD,P_LEVELS) !INOUT V FIELD, MASS-WEIGHTED ON OUT. ADVCTL1A.88
*,THETAL(P_FIELD,P_LEVELS) !INOUT THETAL FIELD ADVCTL1A.89
*,QT(P_FIELD,Q_LEVELS) !INOUT QT FIELD. ADVCTL1A.90
ADVCTL1A.91
REAL ADVCTL1A.92
* DELTA_AK(P_LEVELS) !IN LAYER THICKNESS ADVCTL1A.93
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS ADVCTL1A.94
*,AK(P_LEVELS) !IN FIRST TERM IN HYBRID CO-ORDS. ADVCTL1A.95
*,BK(P_LEVELS) !IN SECOND TERM IN HYBRID CO-ORDS. ADVCTL1A.96
*,AKH(P_LEVELS+1) !IN AK AT HALF LEVELS ADVCTL1A.97
*,BKH(P_LEVELS+1) !IN BK AT HALF LEVELS ADVCTL1A.98
&,COS_P_LATITUDE(P_FIELD) !IN COS_LAT AT P_POINTS (2D ARRAY) ATD1F400.164
*,SEC_P_LATITUDE(P_FIELD) !IN 1/COS(LAT) AT P POINTS (2-D ARRAY) ADVCTL1A.99
*,COS_U_LATITUDE(U_FIELD) !IN COS(LAT) AT U POINTS (2-D ARRAY) ADVCTL1A.100
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) ADVCTL1A.101
*,COS_U_LONGITUDE(ROW_LENGTH) !IN COS(LONGITUDE) AT U-POINTS. ADVCTL1A.102
*,SIN_U_LONGITUDE(ROW_LENGTH) !IN SIN(LONGITUDE) AT U-POINTS. ADVCTL1A.103
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) ADVCTL1A.104
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) ADVCTL1A.105
*,ADVECTION_TIMESTEP !IN ADVCTL1A.106
*,NU_BASIC !IN STANDARD NU TERM FOR MODEL RUN. ADVCTL1A.107
*,F1(U_FIELD) !IN A CORIOLIS TERM SEE DOCUMENTATION ADVCTL1A.108
*,F2(U_FIELD) !IN A CORIOLIS TERM SEE DOCUMENTATION ADVCTL1A.109
*,KD(P_LEVELS) !IN DIVERGENCE DAMPING COEFFICIENTS ADVCTL1A.110
ADVCTL1A.111
REAL ADVCTL1A.112
* OMEGA(U_FIELD,P_LEVELS) !OUT TRUE VERTICAL VELOCITY ADVCTL1A.113
C*--------------------------------------------------------------------- ADVCTL1A.114
ADVCTL1A.115
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- ADVCTL1A.116
C DEFINE LOCAL ARRAYS: 3 ARE REQUIRED ATD1F400.165
REAL ADVCTL1A.118
* WORK1(U_FIELD) ! GENERAL WORKSPACE ADVCTL1A.119
*,WORK2(P_FIELD) ! GENERAL WORKSPACE ADVCTL1A.120
&, OMEGA_P(P_FIELD) ! HOLDS OMEGA AT P POINTS. ATD1F400.166
ADVCTL1A.121
C*--------------------------------------------------------------------- ADVCTL1A.122
C DEFINE LOCAL VARIABLES ADVCTL1A.123
ADVCTL1A.124
C COUNT VARIABLES FOR DO LOOPS ETC. ATD1F400.167
INTEGER ATD1F400.168
& I,K,K1 ATD1F400.169
ATD1F400.170
INTEGER X_FIELD ! 1 IF 2ND ORDER ELSE U_FIELD IF 4TH ORDER AAD3F304.9
AAD3F304.10
C REAL SCALARS ATD1F400.171
REAL ATD1F400.172
& CONST1,LC_LF,TIMESTEP ATD1F400.173
& ,PK, PK1 ! Pressure at half levels ATD1F400.174
& ,P_EXNER_FULL ! Exner pressure at full model level ATD1F400.175
ATD1F400.176
C LOGICAL VARIABLE ADVCTL1A.129
LOGICAL ADVCTL1A.130
* L_SECOND ! SET TO TRUE IF NU_BASIC EQUAL TO ZERO ADVCTL1A.131
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- ADVCTL1A.132
EXTERNAL TH_ADV,QT_ADV,UV_ADV,P_TO_UV,DIV_DAMP MM240293.28
& ,TRAC_ADV,TRAC_VERT_ADV,UV_TO_P,POLAR ATD1F400.177
C*--------------------------------------------------------------------- ADVCTL1A.134
GSS1F403.654
*IF DEF,MPP GSS1F403.655
INTEGER extended_address(P_FIELD) GSS1F403.656
*ENDIF GSS1F403.657
GSS1F403.658
*CALL C_THADV ATD1F400.178
*CALL P_EXNERC ATD1F400.179
ATD1F400.180
ADVCTL1A.135
*IF DEF,MPP GSS1F403.659
IF (NU_BASIC .NE. 0.0) THEN GSS1F403.660
! Calculate the mapping between points on the normal horizontal GSS1F403.661
! field, and points in the extended field (with double halos for GSS1F403.662
! the fourth order code) GSS1F403.663
! Logic: extended_address=old_address GSS1F403.664
! + ROW_LENGTH*extra_NS_Halo GSS1F403.665
! -> extra halo row at top of field GSS1F403.666
! + (row_number+1)*2*extra_EW_Halo GSS1F403.667
! -> two extra halo points for each preceeding row GSS1F403.668
! + extra_EW_Halo -> extra halo point at start of this row GSS1F403.669
DO I=FIRST_VALID_PT,LAST_P_VALID_PT GSS1F403.670
extended_address(I)=I + ROW_LENGTH*extra_NS_Halo + GSS1F403.671
& (((I-1)/ROW_LENGTH)+extra_NS_Halo)*2*extra_EW_Halo + GSS1F403.672
& extra_EW_Halo GSS1F403.673
ENDDO GSS1F403.674
ENDIF GSS1F403.675
*ENDIF GSS1F403.676
CL MAXIMUM VECTOR LENGTH ASSUMED IS U_FIELD. ADVCTL1A.136
CL--------------------------------------------------------------------- ADVCTL1A.137
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: ADVCTL1A.138
CL--------------------------------------------------------------------- ADVCTL1A.139
CL ADVCTL1A.140
C**************************************************************** ATD1F400.181
C INTEGERS AND VARIABLES NEEDED WHEN USING ATD1F400.182
C TRACER ADVECTION OF THETAL & QT ATD1F400.183
C***************************************************************** ATD1F400.184
IF(L_TRACER_THETAL_QT)THEN ATD1F400.185
LC_LF=LC + LF ATD1F400.186
P_POINTS_UPDATE=upd_P_ROWS*ROW_LENGTH APB0F401.702
START_U_REQUIRED = START_POINT_NO_HALO-ROW_LENGTH APB0F401.703
P_POINTS_REQUIRED = (upd_P_ROWS+2)*ROW_LENGTH APB0F401.704
U_POINTS_REQUIRED = (upd_U_ROWS+2)*ROW_LENGTH APB0F401.705
ENDIF ATD1F400.194
CL--------------------------------------------------------------------- ADVCTL1A.141
CL SECTION 1. INTERPOLATE FIELDS ONTO U GRID. ADVCTL1A.142
CL--------------------------------------------------------------------- ADVCTL1A.143
ADVCTL1A.144
IF(NU_BASIC.EQ.0.) THEN ADVCTL1A.145
L_SECOND=.TRUE. ADVCTL1A.146
X_FIELD=1 AAD3F304.11
ELSE ADVCTL1A.147
L_SECOND=.FALSE. ADVCTL1A.148
X_FIELD=U_FIELD AAD3F304.12
END IF ADVCTL1A.149
*IF DEF,MPP ARB2F402.28
! Initialise arrays WORK1 & WORK2 ARB2F402.29
DO I = 1,P_FIELD ARB2F402.30
WORK1(I) = 1.0 ARB2F402.31
WORK2(I) = 1.0 ARB2F402.32
END DO ARB2F402.33
*ENDIF ARB2F402.34
ADVCTL1A.150
C---------------------------------------------------------------------- ADVCTL1A.151
CL SECTION 1.1 INTERPOLATE PSTAR ONTO U GRID. ADVCTL1A.152
C---------------------------------------------------------------------- ADVCTL1A.153
ADVCTL1A.154
CALL P_TO_UV(PSTAR,WORK1,P_FIELD,U_FIELD,ROW_LENGTH,tot_P_ROWS) APB0F401.706
ADVCTL1A.156
C---------------------------------------------------------------------- ADVCTL1A.157
CL SECTION 1.2 INTERPOLATE PSTAR_OLD ONTO U GRID. ADVCTL1A.158
C---------------------------------------------------------------------- ADVCTL1A.159
ADVCTL1A.160
CALL P_TO_UV(PSTAR_OLD,WORK2,P_FIELD,U_FIELD,ROW_LENGTH, APB0F401.707
& tot_P_ROWS) APB0F401.708
APB0F401.709
*IF DEF,MPP APB0F401.710
! Update the halos of WORK1 and WORK2 APB0F401.711
CALL SWAPBOUNDS(WORK1,ROW_LENGTH,tot_P_ROWS,EW_Halo,NS_Halo,1) APB0F401.712
CALL SWAPBOUNDS(WORK2,ROW_LENGTH,tot_P_ROWS,EW_Halo,NS_Halo,1) APB0F401.713
! Hopefully we shouldn't need these lines if loop bounds are right APB0F401.714
! CALL SET_SIDES(WORK1,U_FIELD,ROW_LENGTH,1,fld_type_u) APB0F401.715
! CALL SET_SIDES(WORK2,U_FIELD,ROW_LENGTH,1,fld_type_u) APB0F401.716
*ENDIF APB0F401.717
ADVCTL1A.162
CL ADVCTL1A.163
CL--------------------------------------------------------------------- ADVCTL1A.164
CL SECTION 2. CALL DIV_DAMP TO PERFORM DIVERGENCE DAMPING. ADVCTL1A.165
CL--------------------------------------------------------------------- ADVCTL1A.166
ADVCTL1A.167
C PSTAR_OLD ON U GRID IS HELD IN WORK2. ADVCTL1A.168
ADVCTL1A.169
CALL DIV_DAMP(U,V,RS,SEC_U_LATITUDE,WORK2,COS_U_LATITUDE,KD, ADVCTL1A.170
* LONGITUDE_STEP_INVERSE,LATITUDE_STEP_INVERSE, ADVCTL1A.171
* P_FIELD,U_FIELD,ROW_LENGTH,P_LEVELS, APB0F401.718
*CALL ARGFLDPT APB0F401.719
* BKH,ADVECTION_TIMESTEP,DELTA_AK,DELTA_BK, ADVCTL1A.173
* COS_U_LONGITUDE,SIN_U_LONGITUDE,SEC_P_LATITUDE) ADVCTL1A.174
ADVCTL1A.175
CL ADVCTL1A.176
CL--------------------------------------------------------------------- ADVCTL1A.177
CL SECTION 3. CALL UV_ADV TO ADVECT U AND V. ADVCTL1A.178
CL--------------------------------------------------------------------- ADVCTL1A.179
ADVCTL1A.180
C PSTAR ON U GRID IS HELD IN WORK1. ADVCTL1A.181
C PSTAR_OLD ON U GRID IS HELD IN WORK2. ADVCTL1A.182
ADVCTL1A.183
CALL UV_ADV (U,V,WORK2,WORK1,U_MEAN,V_MEAN, ADVCTL1A.184
* SEC_U_LATITUDE,ETADOT_MEAN,RS,DELTA_AK,DELTA_BK,AK, ADVCTL1A.185
* BK,F1,F2,LATITUDE_STEP_INVERSE,ADVECTION_TIMESTEP, ADVCTL1A.186
* NU_BASIC,LONGITUDE_STEP_INVERSE,U_FIELD,P_FIELD, APB0F401.720
* ROW_LENGTH,P_LEVELS, APB0F401.721
*CALL ARGFLDPT APB0F401.722
* COS_U_LONGITUDE,SIN_U_LONGITUDE,SEC_P_LATITUDE, APB0F401.723
& AKH,BKH,OMEGA,L_SECOND,LLINTS, ATD1F400.195
*IF DEF,MPP GSS1F403.677
& extended_address, GSS1F403.678
*ENDIF GSS1F403.679
& LWHITBROM,X_FIELD) GSS1F304.797
*IF DEF,MPP APB0F305.509
! Update the halos for the OMEGA array APB0F401.724
CALL SWAPBOUNDS(OMEGA,ROW_LENGTH,tot_P_ROWS, APB0F401.725
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.726
APB0F305.512
! U and V are not swapped here, but in ATM_DYN, after the call to APB0F305.513
! MASS_UWT which spoils the halo. APB0F305.514
APB0F305.515
*ENDIF APB0F305.516
CL ADVCTL1A.192
CL--------------------------------------------------------------------- ADVCTL1A.193
CL SECTION 4. CALL TH_ADV TO ADVECT THETAL AND QT_ADV TO ADVECT ADVCTL1A.194
CL QT USING STANDARD HEUN ADVECTION. ATD1F400.196
CL IF USING TRACER ADVECTION FOR THETAL & QT ATD1F400.197
CL THEN CALL APPROPRIATE TRACER ROUTINES. ATD1F400.198
CL--------------------------------------------------------------------- ADVCTL1A.196
IF(.NOT.L_TRACER_THETAL_QT)THEN ATD1F400.199
CL--------------------------------------------------------------- ATD1F400.200
C SECTION 4.1 HEUN ADVVECTION SCHEME ATD1F400.201
C ATD1F400.202
CL---------------------------------------------------------------- ATD1F400.203
ADVCTL1A.197
CALL TH_ADV (THETAL,PSTAR_OLD,PSTAR,U_MEAN,V_MEAN,SEC_P_LATITUDE, ADVCTL1A.198
* ETADOT_MEAN,RS,DELTA_AK,DELTA_BK,LATITUDE_STEP_INVERSE ADVCTL1A.199
* ,ADVECTION_TIMESTEP,NU_BASIC,LONGITUDE_STEP_INVERSE, ADVCTL1A.200
* NORTHERN_FILTERED_P_ROW,SOUTHERN_FILTERED_P_ROW, ADVCTL1A.201
* P_LEVELS,U_FIELD,P_FIELD,ROW_LENGTH, APB0F401.727
*CALL ARGFLDPT APB0F401.728
* TRIGS,IFAX,FILTER_WAVE_NUMBER_P_ROWS,SEC_U_LATITUDE, ADVCTL1A.203
* AKH,BKH,QCL,QCF,P_EXNER,OMEGA, ADVCTL1A.204
& Q_LEVELS,AK,BK,L_SECOND, GSS1F403.680
*IF DEF,MPP GSS1F403.681
& extended_address, GSS1F403.682
*ENDIF GSS1F403.683
& LWHITBROM) GSS1F403.684
ADVCTL1A.206
*IF DEF,MPP APB0F305.517
! Update the halos for the THETAL array APB0F401.729
CALL SWAPBOUNDS(THETAL,ROW_LENGTH,tot_P_ROWS, APB0F401.730
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.731
APB0F305.520
*ENDIF APB0F305.521
CALL QT_ADV (QT,PSTAR_OLD,PSTAR,U_MEAN,V_MEAN,SEC_P_LATITUDE, ADVCTL1A.207
* ETADOT_MEAN,RS,DELTA_AK,DELTA_BK,LATITUDE_STEP_INVERSE ADVCTL1A.208
* ,ADVECTION_TIMESTEP,NU_BASIC,LONGITUDE_STEP_INVERSE, ADVCTL1A.209
* NORTHERN_FILTERED_P_ROW,SOUTHERN_FILTERED_P_ROW, ADVCTL1A.210
* Q_LEVELS,P_LEVELS,U_FIELD,P_FIELD,ROW_LENGTH, APB0F401.732
*CALL ARGFLDPT APB0F401.733
* TRIGS,IFAX,FILTER_WAVE_NUMBER_P_ROWS, APB0F401.734
& SEC_U_LATITUDE,AKH,BKH,L_SECOND, ATD1F400.205
*IF DEF,MPP GSS1F403.685
& extended_address, GSS1F403.686
*ENDIF GSS1F403.687
& LWHITBROM) GSS1F304.800
ADVCTL1A.214
*IF DEF,MPP APB0F401.735
! Update the halos for the QT array APB0F401.736
CALL SWAPBOUNDS(QT,ROW_LENGTH,tot_P_ROWS, APB0F401.737
& EW_Halo,NS_Halo,Q_LEVELS) APB0F401.738
*ENDIF APB0F401.739
ELSE ATD1F400.206
CL--------------------------------------------------------------- ATD1F400.207
C SECTION 4.2 TRACER ADVECTION OF THETAL AND QT ATD1F400.208
C ATD1F400.209
CL---------------------------------------------------------------- ATD1F400.210
DO K=1,P_LEVELS ATD1F400.211
CALL TRAC_ADV(THETAL(1,K),NSWEEP(1,K),U_MEAN(1,K),V_MEAN(1,K), ATD1F400.212
& U_FIELD,P_FIELD,ADVECTION_TIMESTEP,ROW_LENGTH, ATD1F400.213
*CALL ARGFLDPT ARB1F402.10
& SEC_P_LATITUDE,COS_P_LATITUDE,RS(1,K), ARB1F402.11
& PSTAR_OLD,DELTA_AK(K),DELTA_BK(K), ATD1F400.215
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ATD1F400.216
& L_SUPERBEE) ATD1F400.217
END DO ATD1F400.218
ATD1F400.219
C Set temperature flux through lower boundary to zero ATD1F400.220
DO I=1,P_FIELD ATD1F400.221
WORK2(I)=0. ATD1F400.222
END DO ATD1F400.223
ATD1F400.224
*IF DEF,MPP ARB1F402.12
FIRST_POINT = START_POINT_NO_HALO ARB1F402.13
POINTS = upd_P_ROWS * ROW_LENGTH ARB1F402.14
*IF DEF,GLOBAL ATD1F400.225
! If processor includes North or South polar row, compute a pt. on it ARB1F402.15
IF (at_top_of_LPG) THEN ARB1F402.16
FIRST_POINT = FIRST_POINT -Offx -1 ARB1F402.17
POINTS = POINTS +Offx +1 ARB1F402.18
END IF ARB1F402.19
IF (at_base_of_LPG) THEN ARB1F402.20
POINTS = POINTS +Offx +1 ARB1F402.21
END IF ARB1F402.22
*ENDIF ARB1F402.23
*ELSE ARB1F402.24
*IF DEF,GLOBAL ARB1F402.25
FIRST_POINT=ROW_LENGTH ATD1F400.226
POINTS = P_FIELD - 2*ROW_LENGTH + 2 ATD1F400.227
*ELSE ATD1F400.228
FIRST_POINT=ROW_LENGTH+2 ATD1F400.229
POINTS = P_FIELD - 2*ROW_LENGTH - 2 ATD1F400.230
*ENDIF ATD1F400.231
*ENDIF ARB1F402.26
ATD1F400.232
TIMESTEP=ADVECTION_TIMESTEP ATD1F400.233
CONST1=R/(CP*CP)*TIMESTEP ATD1F400.234
CALL TRAC_VERT_ADV(THETAL,ETADOT_MEAN,PSTAR,P_FIELD, ATD1F400.235
& TIMESTEP,1,P_LEVELS,FIRST_POINT, ATD1F400.236
& POINTS,P_LEVELS,1,P_LEVELS,RS,AK,BK,DELTA_AK, ATD1F400.237
& DELTA_BK,WORK2,L_TRACER_THETAL_QT,L_SUPERBEE) ATD1F400.238
C --------------------------------------------------------------------- ATD1F400.239
CL INTERPOLATE OMEGA TO P GRID AND CALCULATE ATD1F400.240
CL REMAINING TERM IN ADVECTION EQUATION. ATD1F400.241
CL CALCULATE TOTAL MASS-WEIGHTED INCREMENT TO FIELD. ATD1F400.242
C --------------------------------------------------------------------- ATD1F400.243
ATD1F400.244
DO 110 K=1,P_LEVELS ATD1F400.245
ATD1F400.246
CALL UV_TO_P(OMEGA(START_U_REQUIRED,K), ATD1F400.247
& OMEGA_P(START_POINT_NO_HALO),U_POINTS_REQUIRED, APB0F401.740
& P_POINTS_UPDATE,ROW_LENGTH,upd_P_ROWS+1) APB0F401.741
ATD1F400.250
*IF DEF,GLOBAL ATD1F400.251
DO I = FIRST_VALID_PT,FIRST_VALID_PT+ROW_LENGTH-1 ARB1F403.2
OMEGA_P(I)=0. ARB1F403.3
END DO ARB1F403.4
DO I = LAST_P_VALID_PT-ROW_LENGTH+1,LAST_P_VALID_PT ARB1F403.5
OMEGA_P(I)=0. ARB1F403.6
END DO ATD1F400.255
ATD1F400.256
C SET UP POLAR VALUE OF OMEGA ATD1F400.257
ATD1F400.258
CALL POLAR(OMEGA_P,OMEGA_P,OMEGA_P, APB0F401.742
*CALL ARGFLDPT APB0F401.743
& P_FIELD,P_FIELD,P_FIELD, APB0F401.744
& START_POINT_NO_HALO, APB0F401.745
& END_P_POINT_NO_HALO-ROW_LENGTH+1, APB0F401.746
& ROW_LENGTH,1) APB0F401.747
*ENDIF ATD1F400.261
C TOTAL MASS-WEIGHTED HORIZONTAL AND VERTICAL INCREMENTS ARE CALCULATED ATD1F400.262
C SEPARATELY. ATD1F400.263
ATD1F400.264
IF(K.LT.Q_LEVELS+1) THEN ATD1F400.265
DO I = FIRST_POINT,FIRST_POINT+POINTS-1 ARB1F402.27
ATD1F400.267
PK = AKH(K+1)+ BKH(K+1)*PSTAR(I) ATD1F400.268
PK1 = AKH(K) + BKH(K)*PSTAR(I) ATD1F400.269
P_EXNER_FULL = P_EXNER_C ATD1F400.270
& (P_EXNER(I,K+1),P_EXNER(I,K),PK,PK1,KAPPA) ATD1F400.271
ATD1F400.272
WORK2(I) = ATD1F400.273
& -(LC*QCL(I,K)+LC_LF*QCF(I,K))*CONST1* ATD1F400.274
& OMEGA_P(I)/((AK(K)+BK(K)*PSTAR(I)) ATD1F400.275
& *(P_EXNER_FULL)* ATD1F400.276
& RS(I,K)*RS(I,K)*(DELTA_AK(K)+DELTA_BK(K)*PSTAR(I))) ATD1F400.277
THETAL(I,K) =THETAL(I,K)+WORK2(I) ATD1F400.278
END DO ATD1F400.279
END IF ATD1F400.280
ATD1F400.281
CL END LOOP OVER P_LEVELS+1 ATD1F400.282
110 CONTINUE ATD1F400.283
ATD1F400.284
*IF DEF,GLOBAL ATD1F400.285
C Copy polar values along row ATD1F400.286
DO K=1,P_LEVELS ATD1F400.287
*IF DEF,MPP ARB1F402.28
IF (at_top_of_LPG) THEN ARB1F402.29
DO I = FIRST_VALID_PT+Offx,START_POINT_NO_HALO-Offx-2 ARB1F402.30
THETAL(I,K) = THETAL(START_POINT_NO_HALO-Offx-1,K) ARB1F402.31
END DO ARB1F402.32
END IF ARB1F402.33
IF (at_base_of_LPG) THEN ARB1F402.34
DO I = END_P_POINT_NO_HALO+Offx+2,LAST_P_VALID_PT-Offx ARB1F402.35
THETAL(I,K) = THETAL(END_P_POINT_NO_HALO+Offx+1,K) ARB1F402.36
END DO ARB1F402.37
END IF ARB1F402.38
*ELSE ARB1F402.39
DO I=1,ROW_LENGTH-1 ATD1F400.288
THETAL(I,K) = THETAL(ROW_LENGTH,K) ATD1F400.289
THETAL(P_FIELD+1-I,K) = THETAL(P_FIELD+1-ROW_LENGTH,K) ATD1F400.290
END DO ATD1F400.291
*ENDIF ARB1F402.40
END DO ATD1F400.292
*ENDIF ATD1F400.293
*IF DEF,MPP ARB1F402.41
! Update the halos for the THETAL array ARB1F402.42
CALL SWAPBOUNDS(THETAL,ROW_LENGTH,tot_P_ROWS, ARB1F402.43
& EW_Halo,NS_Halo,P_LEVELS) ARB1F402.44
ATD1F400.294
*ENDIF ARB1F402.45
ARB1F402.46
DO K=1,Q_LEVELS ATD1F400.295
CALL TRAC_ADV(QT(1,K),NSWEEP(1,K),U_MEAN(1,K),V_MEAN(1,K), ATD1F400.296
& U_FIELD,P_FIELD,ADVECTION_TIMESTEP,ROW_LENGTH, ATD1F400.297
*CALL ARGFLDPT ARB1F402.47
& SEC_P_LATITUDE,COS_P_LATITUDE,RS(1,K), ARB1F402.48
& PSTAR_OLD,DELTA_AK(K),DELTA_BK(K), ATD1F400.299
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ATD1F400.300
& L_SUPERBEE) ATD1F400.301
END DO ATD1F400.302
ATD1F400.303
C Set moisture flux through lower boundary to zero ATD1F400.304
DO I=1,P_FIELD ATD1F400.305
WORK2(I)=0. ATD1F400.306
END DO ATD1F400.307
ATD1F400.308
! Values of FIRST_POINT and POINTS ARB1F402.49
! should be unaltered from those set for Thetal ARB1F402.50
ATD1F400.316
CALL TRAC_VERT_ADV(QT,ETADOT_MEAN,PSTAR,P_FIELD, ATD1F400.317
& TIMESTEP,1,Q_LEVELS,FIRST_POINT, ATD1F400.318
& POINTS,P_LEVELS,1,Q_LEVELS,RS,AK,BK,DELTA_AK, ATD1F400.319
& DELTA_BK,WORK2,L_TRACER_THETAL_QT,L_SUPERBEE) ATD1F400.320
ATD1F400.321
C END DO ATD1F400.322
ATD1F400.323
*IF DEF,GLOBAL ATD1F400.324
C Copy polar values along row ATD1F400.325
DO K=1,Q_LEVELS ATD1F400.326
*IF DEF,MPP ARB1F402.51
IF (at_top_of_LPG) THEN ARB1F402.52
DO I = FIRST_VALID_PT+Offx,START_POINT_NO_HALO-Offx-2 ARB1F402.53
QT(I,K) = QT(START_POINT_NO_HALO-Offx-1,K) ARB1F402.54
END DO ARB1F402.55
END IF ARB1F402.56
IF (at_base_of_LPG) THEN ARB1F402.57
DO I = END_P_POINT_NO_HALO+Offx+2,LAST_P_VALID_PT-Offx ARB1F402.58
QT(I,K) = QT(END_P_POINT_NO_HALO+Offx+1,K) ARB1F402.59
END DO ARB1F402.60
END IF ARB1F402.61
*ELSE ARB1F402.62
DO I=1,ROW_LENGTH-1 ATD1F400.327
QT(I,K) = QT(ROW_LENGTH,K) ATD1F400.328
QT(P_FIELD+1-I,K) = QT(P_FIELD+1-ROW_LENGTH,K) ATD1F400.329
END DO ATD1F400.330
*ENDIF ARB1F402.63
END DO ATD1F400.331
*ENDIF ATD1F400.332
*IF DEF,MPP ARB1F402.64
! Update the halos for the QT array ARB1F402.65
CALL SWAPBOUNDS(QT,ROW_LENGTH,tot_P_ROWS, ARB1F402.66
& EW_Halo,NS_Halo,Q_LEVELS) ARB1F402.67
*ENDIF ARB1F402.68
ENDIF ! L_TRACER_THETAL_QT ARB1F402.69
ADVCTL1A.215
CL END OF ROUTINE ADV_CTL ADVCTL1A.216
ADVCTL1A.217
RETURN ADVCTL1A.218
END ADVCTL1A.219
*ENDIF ADVCTL1A.220