*IF DEF,A12_1B ARB2F400.2
C ******************************COPYRIGHT****************************** GTS2F400.235
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.236
C GTS2F400.237
C Use, duplication or disclosure of this code is subject to the GTS2F400.238
C restrictions as set forth in the contract. GTS2F400.239
C GTS2F400.240
C Meteorological Office GTS2F400.241
C London Road GTS2F400.242
C BRACKNELL GTS2F400.243
C Berkshire UK GTS2F400.244
C RG12 2SZ GTS2F400.245
C GTS2F400.246
C If no contract has been raised with this copy of the code, the use, GTS2F400.247
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.248
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.249
C Modelling at the above address. GTS2F400.250
C ******************************COPYRIGHT****************************** GTS2F400.251
C GTS2F400.252
CLL SUBROUTINE ADV_P_GD ------------------------------------------- ADVPGD1A.3
CLL ADVPGD1A.4
CLL PURPOSE: CALCULATES ADVECTION INCREMENTS TO A FIELD AT A ADVPGD1A.5
CLL SINGLE MODEL LEVEL USING AN EQUATION OF THE FORM(36). ADVPGD1A.6
CLL NOT SUITABLE FOR SINGLE COLUMN USE. ADVPGD1A.7
CLL ADVPGD1A.8
CLL VERSION FOR CRAY Y-MP ADVPGD1A.9
CLL ADVPGD1A.10
CLL WRITTEN BY M.H MAWSON. ADVPGD1A.11
CLL ADVPGD1A.12
CLL Model Modification history from model version 3.0: ADVPGD1A.13
CLL version Date ADVPGD1A.14
CLL ADVPGD1A.15
CLL 3.4 06/08/94 Vertical advection code restructured to improve AAD2F304.446
CLL parallel efficiency on C90. AAD2F304.447
CLL Authors: A. Dickinson, D. Salmond AAD2F304.448
CLL Reviewer: M. Mawson AAD2F304.449
CLL AAD2F304.450
CLL 3.4 23/06/94 DEF NOWHBR replaced by LOGICAL LWHITBROM GSS1F304.801
CLL S.J.Swarbrick GSS1F304.802
! 3.5 28/03/95 MPP code: Change updateable area and APB0F305.527
! remove explicit wrap around calcs. P.Burton APB0F305.528
! 4.1 29/04/96 Remove MPP code (new ADVPGD1C version for MPP) APB0F401.748
! and add TYPFLDPT arguments APB0F401.749
CLL GSS1F304.803
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, ADVPGD1A.16
CLL STANDARD B. VERSION 2, DATED 18/01/90 ADVPGD1A.17
CLL ADVPGD1A.18
CLL LOGICAL COMPONENTS COVERED: P121 ADVPGD1A.19
CLL ADVPGD1A.20
CLL PROJECT TASK: P1 ADVPGD1A.21
CLL ADVPGD1A.22
CLL DOCUMENTATION: THE EQUATION USED IS (35) ADVPGD1A.23
CLL IN UNIFIED MODEL DOCUMENTATION PAPER NO. 10 ADVPGD1A.24
CLL M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON ADVPGD1A.25
CLLEND------------------------------------------------------------- ADVPGD1A.26
C ADVPGD1A.27
C*L ARGUMENTS:--------------------------------------------------- ADVPGD1A.28
SUBROUTINE ADV_P_GD 34,6ADVPGD1A.29
1 (FIELD_LOWER,FIELD,FIELD_UPPER,U,V, AAD2F304.451
1 ETADOT_LOWER,ETADOT_UPPER, AAD2F304.452
2 SEC_P_LATITUDE,FIELD_INC,NUX,NUY,P_FIELD, ADVPGD1A.31
3 U_FIELD,ROW_LENGTH, APB0F401.750
*CALL ARGFLDPT 
APB0F401.751
4 ADVECTION_TIMESTEP, APB0F401.752
5 LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ADVPGD1A.34
6 SEC_U_LATITUDE,BRSP, AAD2F304.453
7 L_SECOND,LWHITBROM) AAD2F304.454
ADVPGD1A.37
IMPLICIT NONE ADVPGD1A.38
ADVPGD1A.39
INTEGER ADVPGD1A.40
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. ADVPGD1A.41
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID ADVPGD1A.42
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW ADVPGD1A.43
! All TYPFLDPT arguments are intent IN APB0F401.753
*CALL TYPFLDPT APB0F401.754
ADVPGD1A.46
LOGICAL ADVPGD1A.47
* L_SECOND ! SET TO TRUE IF NU_BASIC IS ZERO. ADVPGD1A.48
* ,LWHITBROM ! SWITCH FOR WHITE & BROMLEY TERMS GSS1F304.804
ADVPGD1A.49
REAL ADVPGD1A.50
* U(U_FIELD) !IN ADVECTING U FIELD, MASS-WEIGHTED. ADVPGD1A.51
*,V(U_FIELD) !IN ADVECTING V FIELD, MASS-WEIGHTED. ADVPGD1A.52
*,ETADOT_UPPER(P_FIELD)!IN ADVECTING VERTICAL VELOC AT K+1/2, AAD2F304.455
* ! MASS-WEIGHTED. AAD2F304.456
*,ETADOT_LOWER(P_FIELD)!IN ADVECTING VERTICAL VELOC AT K-1/2, AAD2F304.457
* ! MASS-WEIGHTED. ADVPGD1A.54
*,FIELD(P_FIELD) !IN FIELD TO BE ADVECTED. ADVPGD1A.55
*,FIELD_UPPER(P_FIELD) !IN FIELD TO BE ADVECTED AT LEVEL + 1 . ADVPGD1A.56
*,FIELD_LOWER(P_FIELD) !IN FIELD TO BE ADVECTED AT LEVEL - 1 . AAD2F304.458
*,NUX(P_FIELD) !IN HOLDS PARAMETER NU FOR EAST-WEST ADVECTION. ADVPGD1A.57
*,NUY(P_FIELD) !IN HOLDS PARAMETER NU FOR NORTH-SOUTH ADVECTION. ADVPGD1A.58
*,SEC_P_LATITUDE(P_FIELD) !IN HOLDS 1/COS(PHI) AT P POINTS. ADVPGD1A.59
*,SEC_U_LATITUDE(U_FIELD) !IN HOLDS 1/COS(PHI) AT U POINTS. ADVPGD1A.60
*,ADVECTION_TIMESTEP !IN ADVPGD1A.61
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) ADVPGD1A.62
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) ADVPGD1A.63
ADVPGD1A.64
REAL ADVPGD1A.65
* BRSP(P_FIELD) !IN BRSP TERM AT LEVEL (SEE DOC.PAPER NO 10) AAD2F304.459
ADVPGD1A.74
REAL ADVPGD1A.75
* FIELD_INC(P_FIELD) !OUT HOLDS INCREMENT TO FIELD. ADVPGD1A.76
C ADVPGD1A.77
C*--------------------------------------------------------------------- ADVPGD1A.78
ADVPGD1A.79
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- ADVPGD1A.80
C DEFINE LOCAL ARRAYS: 3 ARE REQUIRED ADVPGD1A.81
ADVPGD1A.82
REAL ADVPGD1A.83
* WORK(P_FIELD) ! GENERAL WORK-SPACE. ADVPGD1A.84
*,U_TERM(P_FIELD) ! HOLDS U ADVECTION TERM FROM EQUATION (35) ADVPGD1A.85
*,V_TERM(P_FIELD) ! HOLDS V ADVECTION TERM FROM EQUATION (35) ADVPGD1A.86
C*--------------------------------------------------------------------- ADVPGD1A.87
C DEFINE LOCAL VARIABLES ADVPGD1A.88
ADVPGD1A.89
C REAL SCALARS ADVPGD1A.90
REAL ADVPGD1A.91
* SCALAR1,SCALAR2 AAD2F304.460
ADVPGD1A.95
C COUNT VARIABLES FOR DO LOOPS ETC. ADVPGD1A.96
INTEGER ADVPGD1A.97
* I,IJ,IK,IL,IM,J ADVPGD1A.98
ADVPGD1A.99
C*L NO EXTERNAL SUBROUTINE CALLS:------------------------------------ ADVPGD1A.100
C*--------------------------------------------------------------------- ADVPGD1A.101
ADVPGD1A.102
CL MAXIMUM VECTOR LENGTH ASSUMED IS END_P_UPDATE-START_P_UPDATE+1 ADVPGD1A.103
CL--------------------------------------------------------------------- ADVPGD1A.104
CL INTERNAL STRUCTURE. ADVPGD1A.105
CL--------------------------------------------------------------------- ADVPGD1A.106
CL ADVPGD1A.107
CL--------------------------------------------------------------------- ADVPGD1A.108
CL SECTION 1. CALCULATE U_TERM IN EQUATION (35). ADVPGD1A.109
CL--------------------------------------------------------------------- ADVPGD1A.110
ADVPGD1A.111
C---------------------------------------------------------------------- ADVPGD1A.112
CL SECTION 1.1 CALCULATE TERM U D(FIELD)/D(LAMDA). ADVPGD1A.113
C---------------------------------------------------------------------- ADVPGD1A.114
ADVPGD1A.115
C CALCULATE TERM AT ALL POINTS EXCEPT LAST AND STORE IN WORK. ADVPGD1A.116
! Loop over field, missing top and bottom rows APB0F401.755
DO 110 I=START_POINT_NO_HALO,END_P_POINT_NO_HALO-1 APB0F401.756
WORK(I) = .5*(U(I)+U(I-ROW_LENGTH))*LONGITUDE_STEP_INVERSE* ADVPGD1A.118
* (FIELD(I+1) - FIELD(I)) ADVPGD1A.119
110 CONTINUE ADVPGD1A.120
ADVPGD1A.121
*IF DEF,GLOBAL ADVPGD1A.122
C IF GLOBAL MODEL RECALCULATE END-POINT VALUE. ADVPGD1A.123
! Loop over last point of each row, missing top and bottom rows APB0F401.757
DO 112 I=START_POINT_NO_HALO+LAST_ROW_PT-1,END_P_POINT_NO_HALO, APB0F401.758
& ROW_LENGTH APB0F401.759
WORK(I) = .5*(U(I)+U(I-ROW_LENGTH))*LONGITUDE_STEP_INVERSE* ADVPGD1A.125
* (FIELD(I+1-ROW_LENGTH) - FIELD(I)) ADVPGD1A.126
112 CONTINUE ADVPGD1A.127
*ENDIF ADVPGD1A.128
ADVPGD1A.129
C---------------------------------------------------------------------- ADVPGD1A.130
CL SECTION 1.2 CALCULATE U ADVECTION TERM IN EQUATION (35). ADVPGD1A.131
CL IF L_SECOND = TRUE PERFORM SECOND ORDER ADVECTION ADVPGD1A.132
CL ONLY. ADVPGD1A.133
C---------------------------------------------------------------------- ADVPGD1A.134
ADVPGD1A.135
IF(L_SECOND) THEN ADVPGD1A.136
*IF DEF,GLOBAL ADVPGD1A.137
C LOOP OVER ALL POINTS. ADVPGD1A.138
ADVPGD1A.139
! Loop over field, missing top and bottom rows, and first point APB0F401.760
DO J=START_POINT_NO_HALO+1,END_P_POINT_NO_HALO APB0F401.761
U_TERM(J) = .5*(WORK(J)+WORK(J-1)) ADVPGD1A.141
END DO ADVPGD1A.142
ADVPGD1A.143
C CALCULATE VALUES AT FIRST,SECOND AND LAST POINTS ON A ROW. ADVPGD1A.144
C WHERE FIRST LOOP CALCULATED THEM INCORRECTLY. ADVPGD1A.145
ADVPGD1A.146
CFPP$ NODEPCHK ADVPGD1A.147
! Fujitsu vectorization directive GRB0F405.577
!OCL NOVREC GRB0F405.578
! Loop over first point of each row, missing top and bottom rows APB0F401.762
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.763
U_TERM(I) = .5*(WORK(I)+WORK(I+ROW_LENGTH-1)) ADVPGD1A.149
END DO ADVPGD1A.150
ADVPGD1A.151
*ELSE ADVPGD1A.152
C LIMITED AREA MODEL. ADVPGD1A.153
ADVPGD1A.154
! Loop over field, missing top and bottom rows and first and APB0F401.764
! last points. APB0F401.765
DO J=START_POINT_NO_HALO+1,END_P_POINT_NO_HALO-1 APB0F401.766
U_TERM(J) = .5*(WORK(J)+WORK(J-1)) ADVPGD1A.156
END DO ADVPGD1A.157
ADVPGD1A.158
C CORNER VALUES ADVPGD1A.159
ADVPGD1A.160
U_TERM(START_POINT_NO_HALO)=0.0 APB0F401.767
U_TERM(END_P_POINT_NO_HALO)=0.0 APB0F401.768
ADVPGD1A.163
*ENDIF ADVPGD1A.164
ELSE ADVPGD1A.165
*IF DEF,GLOBAL ADVPGD1A.166
C LOOP OVER ALL POINTS. ADVPGD1A.167
ADVPGD1A.168
! Loop over field, missing top and bottom rows and first two points APB0F401.769
! and last point APB0F401.770
DO 120 J=START_POINT_NO_HALO+2,END_P_POINT_NO_HALO-1 APB0F401.771
U_TERM(J) = (1.+NUX(J))*.5*(WORK(J)+WORK(J-1))-NUX(J)*.5* ADVPGD1A.170
* (WORK(J+1)+WORK(J-2)) ADVPGD1A.171
120 CONTINUE ADVPGD1A.172
ADVPGD1A.173
C CALCULATE VALUES AT FIRST,SECOND AND LAST POINTS ON A ROW. ADVPGD1A.174
C WHERE FIRST LOOP CALCULATED THEM INCORRECTLY. ADVPGD1A.175
ADVPGD1A.176
CFPP$ NODEPCHK ADVPGD1A.177
! Fujitsu vectorization directive GRB0F405.579
!OCL NOVREC GRB0F405.580
! Loop over first point of every row, missing top and bottom rows APB0F401.772
DO 124 I=START_POINT_NO_HALO,END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.773
IJ =I+LAST_ROW_PT-1 ! IJ is last point on row APB0F401.774
IK = IJ - 1 ADVPGD1A.180
IL = I + 1 ADVPGD1A.181
C FIRST POINT. ADVPGD1A.182
U_TERM(I) = (1.+NUX(I))*.5*(WORK(I)+WORK(IJ))-NUX(I)*.5* ADVPGD1A.183
* (WORK(IL)+WORK(IK)) ADVPGD1A.184
C SECOND POINT. ADVPGD1A.185
U_TERM(IL) = (1.+NUX(IL))*.5*(WORK(IL)+WORK(I))-NUX(IL)*.5* ADVPGD1A.186
* (WORK(I+2)+WORK(IJ)) ADVPGD1A.187
C LAST POINT. ADVPGD1A.188
U_TERM(IJ) = (1.+NUX(IJ))*.5*(WORK(IJ)+WORK(IK))-NUX(IJ)*.5* ADVPGD1A.189
* (WORK(I)+WORK(IK-1)) ADVPGD1A.190
124 CONTINUE ADVPGD1A.191
ADVPGD1A.192
*ELSE ADVPGD1A.193
C LIMITED AREA MODEL. VALUES NOT CALCULATED AT FIRST,SECOND,NEXT TO LAST ADVPGD1A.194
C AND LAST ON A ROW. ADVPGD1A.195
ADVPGD1A.196
! Loop over field, missing top and bottom rows and first two points APB0F401.775
! and last two points. APB0F401.776
DO 120 J=START_POINT_NO_HALO+2,END_P_POINT_NO_HALO-2 APB0F401.777
U_TERM(J) = (1.+NUX(J))*.5*(WORK(J)+WORK(J-1))-NUX(J)*.5* ADVPGD1A.198
* (WORK(J+1)+WORK(J-2)) ADVPGD1A.199
120 CONTINUE ADVPGD1A.200
ADVPGD1A.201
C CALCULATE VALUES AT SECOND AND NEXT TO LAST POINTS ON A ROW. ADVPGD1A.202
C THESE VALUES ARE JUST SECOND ORDER. ADVPGD1A.203
ADVPGD1A.204
! Loop over first point of every row, missing top and bottom rows APB0F401.778
DO 124 I=START_POINT_NO_HALO,END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.779
IK = I+LAST_ROW_PT-2 ! IK is penultimate point of row APB0F401.780
IL = I + 1 ADVPGD1A.207
C SECOND POINT. ADVPGD1A.208
U_TERM(IL) = .5*(WORK(IL)+WORK(I)) ADVPGD1A.209
C NEXT TO LAST POINT. ADVPGD1A.210
U_TERM(IK) = .5*(WORK(IK)+WORK(IK-1)) ADVPGD1A.211
124 CONTINUE ADVPGD1A.212
C CORNER VALUES ADVPGD1A.213
C ADVPGD1A.214
U_TERM(START_POINT_NO_HALO)=0.0 APB0F401.781
U_TERM(END_P_POINT_NO_HALO)=0.0 APB0F401.782
C ADVPGD1A.217
ADVPGD1A.218
*ENDIF ADVPGD1A.219
END IF ADVPGD1A.220
ADVPGD1A.221
CL ADVPGD1A.222
CL--------------------------------------------------------------------- ADVPGD1A.223
CL SECTION 2. CALCULATE V_TERM IN EQUATION (35). ADVPGD1A.224
CL--------------------------------------------------------------------- ADVPGD1A.225
ADVPGD1A.226
C---------------------------------------------------------------------- ADVPGD1A.227
CL SECTION 2.1 CALCULATE TERM V D(FIELD)/D(PHI). ADVPGD1A.228
C---------------------------------------------------------------------- ADVPGD1A.229
ADVPGD1A.230
C CALCULATE TERM AT ALL POINTS EXCEPT FIRST AND STORE IN WORK. ADVPGD1A.231
! Loop over field, missing bottom row and first point of top row APB0F401.783
DO 210 I=START_POINT_NO_HALO-ROW_LENGTH+1,END_P_POINT_NO_HALO APB0F401.784
WORK(I) = .5*(V(I)+V(I-1))*LATITUDE_STEP_INVERSE* ADVPGD1A.233
* (FIELD(I) - FIELD(I+ROW_LENGTH)) ADVPGD1A.234
210 CONTINUE ADVPGD1A.235
ADVPGD1A.236
*IF DEF,GLOBAL ADVPGD1A.237
C IF GLOBAL MODEL RECALCULATE FIRST-POINT VALUE. ADVPGD1A.238
! Loop over first point of every row, missing bottom row APB0F401.785
DO 212 I=START_POINT_NO_HALO-ROW_LENGTH,END_P_POINT_NO_HALO, APB0F401.786
& ROW_LENGTH APB0F401.787
WORK(I) = .5*(V(I)+V(I+ROW_LENGTH-1))*LATITUDE_STEP_INVERSE* ADVPGD1A.240
* (FIELD(I) - FIELD(I+ROW_LENGTH)) ADVPGD1A.241
212 CONTINUE ADVPGD1A.242
*ENDIF ADVPGD1A.243
ADVPGD1A.244
C---------------------------------------------------------------------- ADVPGD1A.245
CL SECTION 2.2 CALCULATE V ADVECTION TERM IN EQUATION (35). ADVPGD1A.246
CL IF L_SECOND = TRUE PERFORM SECOND ORDER ADVECTION ADVPGD1A.247
CL ONLY. ADVPGD1A.248
C---------------------------------------------------------------------- ADVPGD1A.249
ADVPGD1A.250
IF(L_SECOND) THEN ADVPGD1A.251
*IF DEF,GLOBAL ADVPGD1A.252
C GLOBAL MODEL. ADVPGD1A.253
C CALCULATE ALL VALUES EXCEPT ON ROWS NEXT TO POLES. ADVPGD1A.254
ADVPGD1A.255
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.788
V_TERM(I) = .5*(WORK(I-ROW_LENGTH)+WORK(I)) ADVPGD1A.257
END DO ADVPGD1A.258
ADVPGD1A.259
C CALCULATE VALUES ON SLICES NEXT TO POLES. ADVPGD1A.260
ADVPGD1A.261
CFPP$ NODEPCHK ADVPGD1A.262
! Fujitsu vectorization directive GRB0F405.581
!OCL NOVREC GRB0F405.582
DO I=1,ROW_LENGTH ADVPGD1A.263
IJ = P_FIELD - ROW_LENGTH + I ADVPGD1A.264
C NEXT TO NORTH POLE SLICE. ADVPGD1A.265
V_TERM(I) = WORK(I)*.5 ADVPGD1A.266
C NEXT TO SOUTH POLE SLICE. ADVPGD1A.267
V_TERM(IJ) = WORK(IJ-ROW_LENGTH)*.5 ADVPGD1A.268
END DO ADVPGD1A.269
ADVPGD1A.270
*ELSE ADVPGD1A.271
C LIMITED AREA MODEL. ADVPGD1A.272
ADVPGD1A.273
! Loop over field, missing top and bottom rows and first and last points APB0F401.789
DO I=START_POINT_NO_HALO+1,END_P_POINT_NO_HALO-1 APB0F401.790
V_TERM(I) = .5*(WORK(I-ROW_LENGTH)+WORK(I)) ADVPGD1A.275
END DO ADVPGD1A.276
ADVPGD1A.277
V_TERM(START_POINT_NO_HALO)=0.0 APB0F401.791
V_TERM(END_P_POINT_NO_HALO)=0.0 APB0F401.792
ADVPGD1A.280
*ENDIF ADVPGD1A.281
ELSE ADVPGD1A.282
*IF DEF,GLOBAL ADVPGD1A.283
C GLOBAL MODEL. ADVPGD1A.284
C CALCULATE ALL VALUES EXCEPT ON ROWS NEXT TO POLES. ADVPGD1A.285
ADVPGD1A.286
! Loop over field missing top and bottom two rows APB0F401.793
DO 220 I=START_POINT_NO_HALO+ROW_LENGTH, APB0F401.794
& END_P_POINT_NO_HALO-ROW_LENGTH APB0F401.795
V_TERM(I) = (1.+NUY(I))*.5*(WORK(I-ROW_LENGTH)+WORK(I)) - ADVPGD1A.288
* NUY(I)*.5*(WORK(I+ROW_LENGTH)+WORK(I-2*ROW_LENGTH)) ADVPGD1A.289
220 CONTINUE ADVPGD1A.290
ADVPGD1A.291
C CALCULATE VALUES ON SLICES NEXT TO POLES. ADVPGD1A.292
ADVPGD1A.293
CFPP$ NODEPCHK ADVPGD1A.294
! Fujitsu vectorization directive GRB0F405.583
!OCL NOVREC GRB0F405.584
DO 222 I=1,ROW_LENGTH ADVPGD1A.295
IJ = END_P_POINT_NO_HALO - ROW_LENGTH + I APB0F401.796
IK = START_POINT_NO_HALO + I - 1 APB0F401.797
IL = MOD(I-1+ROW_LENGTH/2,ROW_LENGTH) + 1 ADVPGD1A.298
IM = MOD(IJ-1+ROW_LENGTH/2,ROW_LENGTH)+P_FIELD-2*ROW_LENGTH+1 ADVPGD1A.299
C NORTH POLE ROWS. ADVPGD1A.300
V_TERM(IK) = (1.+NUY(IK))*.5*(WORK(IK-ROW_LENGTH)+WORK(IK)) - ADVPGD1A.301
* NUY(IK)*.5*(WORK(IK+ROW_LENGTH)+WORK(IL)) ADVPGD1A.302
V_TERM(I) = (1.+NUY(IK))*.5*WORK(I) - ADVPGD1A.303
* NUY(IK)*.5*WORK(IK) ADVPGD1A.304
C SOUTH POLE ROWS. ADVPGD1A.305
V_TERM(IJ) = (1.+NUY(IJ))*.5*(WORK(IJ-ROW_LENGTH)+WORK(IJ)) - ADVPGD1A.306
* NUY(IJ)*.5*(WORK(IM)+WORK(IJ-2*ROW_LENGTH)) ADVPGD1A.307
V_TERM(IJ+ROW_LENGTH) = (1.+NUY(IJ))*.5*WORK(IJ) - ADVPGD1A.308
* NUY(IJ)*.5*WORK(IJ-ROW_LENGTH) ADVPGD1A.309
222 CONTINUE ADVPGD1A.310
ADVPGD1A.311
*ELSE ADVPGD1A.312
C LIMITED AREA MODEL. ADVPGD1A.313
C CALCULATE ALL VALUES EXCEPT ON ROWS NEXT TO BOUNDARIES. ADVPGD1A.314
ADVPGD1A.315
! Loop over field missing top and bottom rows APB0F401.798
DO 220 I=START_POINT_NO_HALO+ROW_LENGTH, APB0F401.799
& END_P_POINT_NO_HALO-ROW_LENGTH APB0F401.800
V_TERM(I) = (1.+NUY(I))*.5*(WORK(I-ROW_LENGTH)+WORK(I)) - ADVPGD1A.317
* NUY(I)*.5*(WORK(I+ROW_LENGTH)+WORK(I-2*ROW_LENGTH)) ADVPGD1A.318
220 CONTINUE ADVPGD1A.319
ADVPGD1A.320
C CALCULATE VALUES ON SLICES NEXT TO BOUNDARIES AS SECOND ORDER. ADVPGD1A.321
ADVPGD1A.322
DO 222 I=2,ROW_LENGTH-1 ADVPGD1A.323
IJ = END_P_POINT_NO_HALO-ROW_LENGTH+I APB0F401.801
IK = START_POINT_NO_HALO+I-1 APB0F401.802
C NEXT TO NORTHERN BOUNDARY. ADVPGD1A.326
V_TERM(IK) = .5*(WORK(IK-ROW_LENGTH)+WORK(IK)) ADVPGD1A.327
C NEXT TO SOUTHERN BOUNDARY. ADVPGD1A.328
V_TERM(IJ) = .5*(WORK(IJ-ROW_LENGTH)+WORK(IJ)) ADVPGD1A.329
222 CONTINUE ADVPGD1A.330
V_TERM(START_POINT_NO_HALO) = 0.0 APB0F401.803
V_TERM(START_POINT_NO_HALO+ROW_LENGTH-1)=0.0 APB0F401.804
C ADVPGD1A.333
V_TERM(END_P_POINT_NO_HALO) = 0.0 APB0F401.805
V_TERM(END_P_POINT_NO_HALO-ROW_LENGTH+1) = 0.0 APB0F401.806
ADVPGD1A.336
*ENDIF ADVPGD1A.337
END IF ADVPGD1A.338
ADVPGD1A.339
CL ADVPGD1A.340
CL--------------------------------------------------------------------- ADVPGD1A.341
CL SECTION 3. CALCULATE VERTICAL FLUX AND COMBINE WITH U AND V ADVPGD1A.342
CL TERMS TO FORM INCREMENT. ADVPGD1A.343
CL--------------------------------------------------------------------- ADVPGD1A.344
ADVPGD1A.345
CL VERTICAL FLUX ON INPUT IS .5*TIMESTEP*ETADOT*D(FIELD)/D(ETA) ADVPGD1A.346
CL AT LEVEL K-1/2. AT THE END OF THIS SECTION IT IS THE SAME ADVPGD1A.347
CL QUANTITY BUT AT LEVEL K+1/2. ADVPGD1A.348
ADVPGD1A.349
! Loop over field missing top and bottom rows. APB0F401.807
DO 300 I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.808
SCALAR1 = .5 * ADVECTION_TIMESTEP * AAD2F304.461
* ETADOT_UPPER(I) * (FIELD_UPPER(I) - FIELD(I)) AAD2F304.462
SCALAR2 = .5 * ADVECTION_TIMESTEP * AAD2F304.463
* ETADOT_LOWER(I) * (FIELD(I) - FIELD_LOWER(I)) AAD2F304.464
FIELD_INC(I) = ADVECTION_TIMESTEP * SEC_P_LATITUDE(I) * ADVPGD1A.353
* (U_TERM(I)+V_TERM(I)) ADVPGD1A.354
& + SCALAR1+SCALAR2 AAD2F304.465
IF (LWHITBROM) THEN GSS1F304.805
FIELD_INC(I) = FIELD_INC(I) GSS1F304.806
* + FIELD(I)*BRSP(I) AAD2F304.466
END IF GSS1F304.807
300 CONTINUE ADVPGD1A.360
ADVPGD1A.361
*IF DEF,GLOBAL ADVPGD1A.362
CFPP$ NODEPCHK ADVPGD1A.363
! Fujitsu vectorization directive GRB0F405.585
!OCL NOVREC GRB0F405.586
DO 310 I=1,ROW_LENGTH ADVPGD1A.364
C NORTH POLE FLUX ADVPGD1A.365
SCALAR1 = .5 * ADVECTION_TIMESTEP * AAD2F304.467
* ETADOT_UPPER(I) * (FIELD_UPPER(I) - FIELD(I)) AAD2F304.468
SCALAR2 = .5 * ADVECTION_TIMESTEP * AAD2F304.469
* ETADOT_LOWER(I) * (FIELD(I) - FIELD_LOWER(I)) AAD2F304.470
FIELD_INC(I) = ADVECTION_TIMESTEP * SEC_P_LATITUDE(I) * ADVPGD1A.368
* V_TERM(I) ADVPGD1A.369
& + SCALAR1+SCALAR2 AAD2F304.471
IF (LWHITBROM) THEN GSS1F304.808
FIELD_INC(I) = FIELD_INC(I) GSS1F304.809
* +FIELD(I)*BRSP(I) AAD2F304.472
END IF GSS1F304.810
310 CONTINUE ADVPGD1A.375
CFPP$ NODEPCHK ADVPGD1A.376
! Fujitsu vectorization directive GRB0F405.587
!OCL NOVREC GRB0F405.588
DO 320 I=1,ROW_LENGTH ADVPGD1A.377
C SOUTH POLE FLUX ADVPGD1A.378
IJ = P_FIELD - ROW_LENGTH + I ADVPGD1A.379
SCALAR1 = .5 * ADVECTION_TIMESTEP * AAD2F304.473
* ETADOT_UPPER(IJ) * (FIELD_UPPER(IJ) - FIELD(IJ)) AAD2F304.474
SCALAR2 = .5 * ADVECTION_TIMESTEP * AAD2F304.475
* ETADOT_LOWER(IJ) * (FIELD(IJ) - FIELD_LOWER(IJ)) AAD2F304.476
FIELD_INC(IJ) = ADVECTION_TIMESTEP * SEC_P_LATITUDE(IJ) * ADVPGD1A.382
* V_TERM(IJ) ADVPGD1A.383
& + SCALAR1+SCALAR2 AAD2F304.477
IF (LWHITBROM) THEN GSS1F304.811
FIELD_INC(IJ) = FIELD_INC(IJ) GSS1F304.812
* +FIELD(IJ)*BRSP(IJ) AAD2F304.478
END IF GSS1F304.813
320 CONTINUE ADVPGD1A.389
*ELSE ADVPGD1A.390
ADVPGD1A.391
CL LIMITED AREA MODEL SET BOUNDARY INCREMENTS AAD2F304.479
CL TO ZERO. ADVPGD1A.393
ADVPGD1A.394
! Loop over first point of each row, missing top and bottom rows. APB0F401.809
DO 310 I=START_POINT_NO_HALO,END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.810
FIELD_INC(I) = 0. ADVPGD1A.396
FIELD_INC(I+ROW_LENGTH-1) = 0. ADVPGD1A.397
310 CONTINUE ADVPGD1A.400
ADVPGD1A.401
*ENDIF ADVPGD1A.402
ADVPGD1A.403
CL END OF ROUTINE ADV_P_GD ADVPGD1A.404
ADVPGD1A.405
RETURN ADVPGD1A.406
END ADVPGD1A.407
*ENDIF ADVPGD1A.408