SUBROUTINE ADV_P_GD 34,6ADVPGD1E.50
1 (P_LEVELS,FIELD,U,V, ADVPGD1E.51
1 ETADOT, ADVPGD1E.52
2 SEC_P_LATITUDE,FIELD_INC,NUX,NUY,P_FIELD, ADVPGD1E.53
3 U_FIELD,ROW_LENGTH, ADVPGD1E.54
*CALL ARGFLDPT 
ADVPGD1E.55
4 ADVECTION_TIMESTEP, ADVPGD1E.56
5 LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ADVPGD1E.57
6 SEC_U_LATITUDE,BRSP, ADVPGD1E.58
7 L_SECOND,LWHITBROM, ADVPGD1E.59
& extended_FIELD, ADVPGD1E.60
& extended_P_FIELD,extended_U_FIELD, ADVPGD1E.61
& extended_address) ADVPGD1E.62
ADVPGD1E.63
IMPLICIT NONE ADVPGD1E.64
ADVPGD1E.65
INTEGER ADVPGD1E.66
* P_LEVELS ADVPGD1E.67
*, P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. ADVPGD1E.68
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID ADVPGD1E.69
&, extended_P_FIELD !IN DIMESNION of P fields with extra halo ADVPGD1E.70
&, extended_U_FIELD !IN DIMESNION of U fields with extra halo ADVPGD1E.71
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW ADVPGD1E.72
ADVPGD1E.73
! All TYPFLDPT arguments are intent IN ADVPGD1E.74
*CALL TYPFLDPT ADVPGD1E.75
ADVPGD1E.76
LOGICAL ADVPGD1E.77
* L_SECOND ! SET TO TRUE IF NU_BASIC IS ZERO. ADVPGD1E.78
* ,LWHITBROM ! SWITCH FOR WHITE & BROMLEY TERMS ADVPGD1E.79
ADVPGD1E.80
REAL ADVPGD1E.81
* U(extended_U_FIELD,P_LEVELS) ADVPGD1E.82
! !IN ADVECTING U FIELD, MASS-WEIGHTED. ADVPGD1E.83
*,V(extended_U_FIELD,P_LEVELS) ADVPGD1E.84
! !IN ADVECTING V FIELD, MASS-WEIGHTED. ADVPGD1E.85
*,ETADOT(P_FIELD,P_LEVELS)!IN ADVECTING VERTICAL VELOC AT K+1/2, ADVPGD1E.86
* ! MASS-WEIGHTED. ADVPGD1E.87
*,FIELD(P_FIELD,P_LEVELS) !IN FIELD TO BE ADVECTED. ADVPGD1E.88
*,NUX(P_FIELD,P_LEVELS) ADVPGD1E.89
! !IN HOLDS PARAMETER NU FOR EAST-WEST ADVECTION. ADVPGD1E.90
*,NUY(P_FIELD,P_LEVELS) ADVPGD1E.91
! !IN HOLDS PARAMETER NU FOR NORTH-SOUTH ADVECTION. ADVPGD1E.92
*,SEC_P_LATITUDE(P_FIELD) !IN HOLDS 1/COS(PHI) AT P POINTS. ADVPGD1E.93
*,SEC_U_LATITUDE(U_FIELD) !IN HOLDS 1/COS(PHI) AT U POINTS. ADVPGD1E.94
*,ADVECTION_TIMESTEP !IN ADVPGD1E.95
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) ADVPGD1E.96
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) ADVPGD1E.97
ADVPGD1E.98
REAL ADVPGD1E.99
* BRSP(P_FIELD,P_LEVELS) ADVPGD1E.100
! !IN BRSP TERM AT LEVEL (SEE DOC.PAPER NO 10) ADVPGD1E.101
ADVPGD1E.102
REAL ADVPGD1E.103
* FIELD_INC(P_FIELD,P_LEVELS) !OUT HOLDS INCREMENT TO FIELD. ADVPGD1E.104
ADVPGD1E.105
REAL ADVPGD1E.106
& extended_FIELD(extended_P_FIELD,P_LEVELS) ADVPGD1E.107
! ! IN field to be advected with ADVPGD1E.108
! ! extra halos for 4th order ADVPGD1E.109
INTEGER extended_address(P_FIELD) ADVPGD1E.110
C ADVPGD1E.111
ADVPGD1E.112
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- ADVPGD1E.113
C DEFINE LOCAL ARRAYS: 3 ARE REQUIRED ADVPGD1E.114
ADVPGD1E.115
REAL ADVPGD1E.116
* WORK(P_FIELD) ! GENERAL WORK-SPACE. ADVPGD1E.117
*,U_TERM(P_FIELD) ! HOLDS U ADVECTION TERM FROM EQUATION (35) ADVPGD1E.118
*,V_TERM(P_FIELD) ! HOLDS V ADVECTION TERM FROM EQUATION (35) ADVPGD1E.119
C*--------------------------------------------------------------------- ADVPGD1E.120
C DEFINE LOCAL VARIABLES ADVPGD1E.121
ADVPGD1E.122
C REAL SCALARS ADVPGD1E.123
REAL ADVPGD1E.124
* SCALAR1,SCALAR2 ADVPGD1E.125
ADVPGD1E.126
C COUNT VARIABLES FOR DO LOOPS ETC. ADVPGD1E.127
INTEGER ADVPGD1E.128
* I,IJ,IK,IL,IM,J,K ADVPGD1E.129
INTEGER START_ADD_base,START_ADD_top ADVPGD1E.130
ADVPGD1E.131
! Work space and scalars for the MPP Fourth Order Advection ADVPGD1E.132
INTEGER info, ! return code from comms operations ADVPGD1E.133
& extended_index, ! index for position in extended array ADVPGD1E.134
& extended_START_POINT_NO_HALO, ADVPGD1E.135
! ! start position in extended array ADVPGD1E.136
& extended_END_P_POINT_NO_HALO, ADVPGD1E.137
! ! end position in extended array ADVPGD1E.138
& extended_ROW_LENGTH ! row length of extended array ADVPGD1E.139
*IF DEF,MPP,AND,DEF,T3E ADVPGD1E.140
ADVPGD1E.141
*CALL AMAXSIZE ADVPGD1E.142
*ENDIF ADVPGD1E.143
ADVPGD1E.144
REAL ADVPGD1E.145
*IF DEF,MPP,AND,DEF,T3E ADVPGD1E.146
& rot_work(row_length_max), ! work space for rotated p ADVPGD1E.147
& rot_work_out(row_length_max), ! work space for rotated p ADVPGD1E.148
*ELSE ADVPGD1E.149
& rot_work(ROW_LENGTH), ! work space for rotated pole rows ADVPGD1E.150
*ENDIF ADVPGD1E.151
& extended_WORK(extended_P_FIELD) ! extended work space ADVPGD1E.152
*IF DEF,MPP,AND,DEF,T3E ADVPGD1E.153
integer ipad1(32), ipad2(32) ADVPGD1E.154
c ADVPGD1E.155
common/adv_p_gd_shmem/ ipad1, rot_work, ipad2 ADVPGD1E.156
c ADVPGD1E.157
*CALL PARVARS ADVPGD1E.158
integer g_start(maxproc), g_new_start, l_new_length, ADVPGD1E.159
2 l_iadd, current_length, l_rem_iadd, my_row_pe ADVPGD1E.160
*ENDIF ADVPGD1E.161
ADVPGD1E.162
ADVPGD1E.163
C*L NO EXTERNAL SUBROUTINE CALLS:------------------------------------ ADVPGD1E.164
C*--------------------------------------------------------------------- ADVPGD1E.165
ADVPGD1E.166
CL MAXIMUM VECTOR LENGTH ASSUMED IS ADVPGD1E.167
CL END_P_POINT_NO_HALO-START_POINT_NO_HALO+1 ADVPGD1E.168
CL--------------------------------------------------------------------- ADVPGD1E.169
ADVPGD1E.170
IF(L_SECOND) THEN APB3F405.3
! SECOND ORDER ADEVCTION APB3F405.4
APB3F405.5
DO K=1,P_LEVELS APB3F405.6
APB3F405.7
CL APB3F405.8
CL--------------------------------------------------------------------- APB3F405.9
CL SECTION 1. CALCULATE U_TERM IN EQUATION (35). APB3F405.10
CL--------------------------------------------------------------------- APB3F405.11
APB3F405.12
C---------------------------------------------------------------------- APB3F405.13
CL SECTION 1.1 CALCULATE TERM U D(FIELD)/D(LAMDA). APB3F405.14
C---------------------------------------------------------------------- APB3F405.15
APB3F405.16
C---------------------------------------------------------------------- APB3F405.17
CL SECTION 1.2 CALCULATE U ADVECTION TERM IN EQUATION (35). APB3F405.18
CL IF L_SECOND = TRUE PERFORM SECOND ORDER ADVECTION APB3F405.19
CL ONLY. APB3F405.20
C---------------------------------------------------------------------- APB3F405.21
APB3F405.22
CL APB3F405.23
CL--------------------------------------------------------------------- APB3F405.24
CL SECTION 2. CALCULATE V_TERM IN EQUATION (35). APB3F405.25
CL--------------------------------------------------------------------- APB3F405.26
APB3F405.27
C---------------------------------------------------------------------- APB3F405.28
CL SECTION 2.1 CALCULATE TERM V D(FIELD)/D(PHI). APB3F405.29
C---------------------------------------------------------------------- APB3F405.30
APB3F405.31
C---------------------------------------------------------------------- APB3F405.32
CL SECTION 2.2 CALCULATE V ADVECTION TERM IN EQUATION (35). APB3F405.33
CL IF L_SECOND = TRUE PERFORM SECOND ORDER ADVECTION APB3F405.34
CL ONLY. APB3F405.35
C---------------------------------------------------------------------- APB3F405.36
APB3F405.37
CL APB3F405.38
CL--------------------------------------------------------------------- APB3F405.39
CL SECTION 3. CALCULATE VERTICAL FLUX AND COMBINE WITH U AND V APB3F405.40
CL TERMS TO FORM INCREMENT. APB3F405.41
CL--------------------------------------------------------------------- APB3F405.42
APB3F405.43
CL VERTICAL FLUX ON INPUT IS .5*TIMESTEP*ETADOT*D(FIELD)/D(ETA) APB3F405.44
CL AT LEVEL K-1/2. AT THE END OF THIS SECTION IT IS THE SAME APB3F405.45
CL QUANTITY BUT AT LEVEL K+1/2. APB3F405.46
APB3F405.47
! Loop over field, missing top and bottom rows and halos APB3F405.48
if(k.ne.1.and.k.ne.P_LEVELS)then APB3F405.49
APB3F405.50
cdir$ unroll4 APB3F405.51
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB3F405.52
SCALAR1 = .5 * ADVECTION_TIMESTEP * APB3F405.53
* ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) APB3F405.54
SCALAR2 = WORK(I) APB3F405.55
FIELD_INC(I,K) = SCALAR1 +SCALAR2 APB3F405.56
IF (LWHITBROM) FIELD_INC(I,K) = FIELD_INC(I,K) APB3F405.57
* + FIELD(I,K)*BRSP(I,K) APB3F405.58
WORK(I)=SCALAR1 APB3F405.59
ENDDO APB3F405.60
else if(k.eq.1) then APB3F405.61
cdir$ unroll4 APB3F405.62
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB3F405.63
SCALAR1 = .5 * ADVECTION_TIMESTEP * APB3F405.64
* ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) APB3F405.65
FIELD_INC(I,K) = SCALAR1 APB3F405.66
IF (LWHITBROM) FIELD_INC(I,K) = FIELD_INC(I,K) APB3F405.67
* + FIELD(I,K)*BRSP(I,K) APB3F405.68
WORK(I)=SCALAR1 APB3F405.69
END DO APB3F405.70
else if(k.eq.P_LEVELS) then APB3F405.71
cdir$ unroll4 APB3F405.72
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB3F405.73
SCALAR2 = WORK(I) APB3F405.74
FIELD_INC(I,K) = SCALAR2 APB3F405.75
IF (LWHITBROM) FIELD_INC(I,K) = FIELD_INC(I,K) APB3F405.76
* + FIELD(I,K)*BRSP(I,K) APB3F405.77
END DO APB3F405.78
endif ! if(k.ne.1.and.k.ne.P_LEVELS)then APB3F405.79
APB3F405.80
DO I=START_POINT_NO_HALO+1,END_P_POINT_NO_HALO-1 APB3F405.81
FIELD_INC(I,K) = FIELD_INC(I,K) + APB3F405.82
* .25*ADVECTION_TIMESTEP * SEC_P_LATITUDE(I) * APB3F405.83
* (LONGITUDE_STEP_INVERSE* APB3F405.84
* ((U(I,K)+U(I-ROW_LENGTH,K))* APB3F405.85
* (FIELD(I+1,K)-FIELD(I,K))+ APB3F405.86
* (U(I-1,K)+U(I-1-ROW_LENGTH,K))* APB3F405.87
* (FIELD(I,K)-FIELD(I-1,K))) APB3F405.88
* + APB3F405.89
* LATITUDE_STEP_INVERSE* APB3F405.90
* ((V(I-ROW_LENGTH,K)+V(I-1-ROW_LENGTH,K))* APB3F405.91
* (FIELD(I-ROW_LENGTH,K) - FIELD(I,K))+ APB3F405.92
& (V(I,K)+V(I-1,K))* APB3F405.93
* (FIELD(I,K) - FIELD(I+ROW_LENGTH,K)))) APB3F405.94
ENDDO APB3F405.95
APB3F405.96
APB3F405.97
*IF DEF,GLOBAL ADVPGD1E.171
APB3F405.98
if(k.ne.1.and.k.ne.P_LEVELS)then APB3F405.99
APB3F405.100
IF (at_top_of_LPG) THEN APB3F405.101
! North Pole Flux APB3F405.102
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB3F405.103
SCALAR1 = 0.5 * ADVECTION_TIMESTEP * APB3F405.104
& ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) APB3F405.105
SCALAR2 = WORK(I) APB3F405.106
FIELD_INC(I,K) = SCALAR1 + SCALAR2 APB3F405.107
APB3F405.108
IF (LWHITBROM) APB3F405.109
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) APB3F405.110
WORK(I)=SCALAR1 APB3F405.111
ENDDO APB3F405.112
ENDIF ! (at_top_of_LPG) APB3F405.113
IF (at_base_of_LPG) THEN ADVPGD1E.175
! South Pole Flux APB3F405.114
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 APB3F405.115
SCALAR1 = 0.5 * ADVECTION_TIMESTEP * APB3F405.116
& ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) APB3F405.117
SCALAR2 = WORK(I) APB3F405.118
FIELD_INC(I,K) = SCALAR1 + SCALAR2 APB3F405.119
APB3F405.120
IF (LWHITBROM) APB3F405.121
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) APB3F405.122
WORK(I)=SCALAR1 APB3F405.123
ENDDO APB3F405.124
ENDIF ! (at_base_of_LPG) APB3F405.125
else if(k.eq.1)then APB3F405.126
IF (at_top_of_LPG) THEN APB3F405.127
! North Pole Flux APB3F405.128
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB3F405.129
SCALAR1 = 0.5 * ADVECTION_TIMESTEP * APB3F405.130
& ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) APB3F405.131
FIELD_INC(I,K) = SCALAR1 APB3F405.132
APB3F405.133
IF (LWHITBROM) APB3F405.134
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) APB3F405.135
WORK(I)=SCALAR1 APB3F405.136
ENDDO APB3F405.137
ENDIF ! (at_top_of_LPG) APB3F405.138
IF (at_base_of_LPG) THEN APB3F405.139
! North Pole Flux & South Pole Flux APB3F405.140
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 APB3F405.141
SCALAR1 = 0.5 * ADVECTION_TIMESTEP * APB3F405.142
& ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) APB3F405.143
FIELD_INC(I,K) = SCALAR1 APB3F405.144
APB3F405.145
IF (LWHITBROM) APB3F405.146
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) APB3F405.147
WORK(I)=SCALAR1 APB3F405.148
ENDDO APB3F405.149
ENDIF ! (at_base_of_LPG) APB3F405.150
else if(k.eq.P_LEVELS) then APB3F405.151
IF (at_top_of_LPG) THEN APB3F405.152
! North Pole Flux APB3F405.153
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB3F405.154
SCALAR2 = WORK(I) APB3F405.155
FIELD_INC(I,K) = SCALAR2 APB3F405.156
APB3F405.157
IF (LWHITBROM) APB3F405.158
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) APB3F405.159
ENDDO APB3F405.160
ENDIF ! (at_top_of_LPG) APB3F405.161
IF (at_base_of_LPG) THEN APB3F405.162
! South Pole Flux APB3F405.163
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 APB3F405.164
SCALAR2 = WORK(I) APB3F405.165
FIELD_INC(I,K) = SCALAR2 APB3F405.166
APB3F405.167
IF (LWHITBROM) APB3F405.168
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) APB3F405.169
ENDDO APB3F405.170
ENDIF ! (at_base_of_LPG) APB3F405.171
endif ! if(k.ne.1.and.k.ne.P_LEVELS) APB3F405.172
IF (at_top_of_LPG) THEN APB3F405.173
DO I=TOP_ROW_START+1,TOP_ROW_START+ROW_LENGTH-1 APB3F405.174
FIELD_INC(I,K) = FIELD_INC(I,K) + APB3F405.175
* ADVECTION_TIMESTEP * SEC_P_LATITUDE(I) * APB3F405.176
* .25*LATITUDE_STEP_INVERSE* APB3F405.177
* (V(I,K)+V(I-1,K))* APB3F405.178
* (FIELD(I,K) - FIELD(I+ROW_LENGTH,K)) APB3F405.179
ENDDO APB3F405.180
ENDIF ! (at_top_of_LPG) APB3F405.181
IF (at_base_of_LPG) THEN APB3F405.182
DO I=P_BOT_ROW_START+1,P_BOT_ROW_START+ROW_LENGTH-1 APB3F405.183
FIELD_INC(I,K) = FIELD_INC(I,K) + APB3F405.184
* ADVECTION_TIMESTEP * SEC_P_LATITUDE(I) * APB3F405.185
* .25*LATITUDE_STEP_INVERSE* APB3F405.186
* (V(I-ROW_LENGTH,K)+V(I-1-ROW_LENGTH,K))* APB3F405.187
* (FIELD(I-ROW_LENGTH,K) - FIELD(I,K)) APB3F405.188
ENDDO APB3F405.189
ENDIF ! (at_base_of_LPG) APB3F405.190
*ENDIF APB3F405.191
APB3F405.192
*IF -DEF,GLOBAL APB3F405.193
APB3F405.194
CL LIMITED AREA MODEL SET BOUNDARY INCREMENTS APB3F405.195
CL TO ZERO. APB3F405.196
APB3F405.197
IF (at_left_of_LPG) THEN APB3F405.198
DO I=START_POINT_NO_HALO+FIRST_ROW_PT-1, APB3F405.199
& END_P_POINT_NO_HALO,ROW_LENGTH APB3F405.200
FIELD_INC(I,K)=0. APB3F405.201
ENDDO APB3F405.202
ENDIF APB3F405.203
APB3F405.204
IF (at_right_of_LPG) THEN APB3F405.205
DO I=START_POINT_NO_HALO+LAST_ROW_PT-1, APB3F405.206
& END_P_POINT_NO_HALO,ROW_LENGTH APB3F405.207
FIELD_INC(I,K)=0. APB3F405.208
ENDDO APB3F405.209
ENDIF ADVPGD1E.177
APB3F405.210
*ENDIF ADVPGD1E.178
ENDDO APB3F405.211
APB3F405.212
ELSE !IF(L_SECOND) APB3F405.213
! FOURTH ORDER ADEVCTION APB3F405.214
APB3F405.215
! Calculate indexes in extended_arrays ADVPGD1E.180
ADVPGD1E.181
extended_ROW_LENGTH=ROW_LENGTH+2*extra_EW_Halo ADVPGD1E.182
ADVPGD1E.183
extended_START_POINT_NO_HALO= ADVPGD1E.184
& extended_address(START_POINT_NO_HALO) ADVPGD1E.185
ADVPGD1E.186
extended_END_P_POINT_NO_HALO= ADVPGD1E.187
& extended_address(END_P_POINT_NO_HALO) ADVPGD1E.188
ADVPGD1E.189
ADVPGD1E.191
DO K=1,P_LEVELS ADVPGD1E.192
ADVPGD1E.193
CL ADVPGD1E.194
CL--------------------------------------------------------------------- ADVPGD1E.195
CL SECTION 1. CALCULATE U_TERM IN EQUATION (35). ADVPGD1E.196
CL--------------------------------------------------------------------- ADVPGD1E.197
ADVPGD1E.198
C---------------------------------------------------------------------- ADVPGD1E.199
CL SECTION 1.1 CALCULATE TERM U D(FIELD)/D(LAMDA). ADVPGD1E.200
C---------------------------------------------------------------------- ADVPGD1E.201
ADVPGD1E.202
C CALCULATE TERM AT ALL POINTS EXCEPT LAST AND STORE IN WORK. ADVPGD1E.203
ADVPGD1E.204
! Loop over extended field, missing top and bottom rows and halos rows ADVPGD1E.217
DO I=extended_START_POINT_NO_HALO-1, ADVPGD1E.218
& extended_END_P_POINT_NO_HALO+1 ADVPGD1E.219
extended_WORK(I)=0.5*(U(I,K)+U(I-extended_ROW_LENGTH,K))* ADVPGD1E.220
& LONGITUDE_STEP_INVERSE* ADVPGD1E.221
& (extended_FIELD(I+1,K)-extended_FIELD(I,K)) ADVPGD1E.222
ENDDO ADVPGD1E.223
ADVPGD1E.224
ADVPGD1E.226
ADVPGD1E.227
C---------------------------------------------------------------------- ADVPGD1E.228
CL SECTION 1.2 CALCULATE U ADVECTION TERM IN EQUATION (35). ADVPGD1E.229
CL IF L_SECOND = TRUE PERFORM SECOND ORDER ADVECTION ADVPGD1E.230
CL ONLY. ADVPGD1E.231
C---------------------------------------------------------------------- ADVPGD1E.232
ADVPGD1E.233
ADVPGD1E.267
C LOOP OVER ALL POINTS. ADVPGD1E.268
ADVPGD1E.269
! Loop over field, missing top and bottom rows and halos, and ADVPGD1E.270
! first point. ADVPGD1E.271
DO 120 J=START_POINT_NO_HALO+1,END_P_POINT_NO_HALO ADVPGD1E.272
extended_index=extended_address(J) ADVPGD1E.273
ADVPGD1E.274
U_TERM(J) = (1.+NUX(J,K))*.5*(extended_WORK(extended_index)+ ADVPGD1E.275
& extended_WORK(extended_index-1)) ADVPGD1E.276
& - NUX(J,K) *.5*(extended_WORK(extended_index+1)+ ADVPGD1E.277
& extended_WORK(extended_index-2)) ADVPGD1E.278
120 CONTINUE ADVPGD1E.279
ADVPGD1E.280
*IF DEF,GLOBAL ADVPGD1E.281
U_TERM(START_POINT_NO_HALO)= U_TERM(START_POINT_NO_HALO+1) ADVPGD1E.282
ADVPGD1E.283
*ELSE ADVPGD1E.284
ARR4F405.12
! Initialise first value to avoid potential flop exception failure ARR4F405.13
ARR4F405.14
U_TERM(START_POINT_NO_HALO)= 0.0 ARR4F405.15
ADVPGD1E.285
C CALCULATE VALUES AT SECOND AND NEXT TO LAST POINTS ON A ROW. ADVPGD1E.286
C THESE VALUES ARE JUST SECOND ORDER. ADVPGD1E.287
ADVPGD1E.288
IF (at_left_of_LPG) THEN ADVPGD1E.289
! Do second point along each row ADVPGD1E.290
DO I=START_POINT_NO_HALO+FIRST_ROW_PT,END_P_POINT_NO_HALO, ADVPGD1E.291
& ROW_LENGTH ADVPGD1E.292
extended_index=extended_address(I) ADVPGD1E.293
ADVPGD1E.294
U_TERM(I)= 0.5*(extended_WORK(extended_index)+ ADVPGD1E.295
& extended_WORK(extended_index-1)) ADVPGD1E.296
ENDDO ADVPGD1E.297
ENDIF ADVPGD1E.298
ADVPGD1E.299
! Do penultimate point along each row ADVPGD1E.300
ADVPGD1E.301
IF (at_right_of_LPG) THEN ADVPGD1E.302
DO I=START_POINT_NO_HALO+LAST_ROW_PT-2,END_P_POINT_NO_HALO, ADVPGD1E.303
& ROW_LENGTH ADVPGD1E.304
extended_index=extended_address(I) ADVPGD1E.305
ADVPGD1E.306
U_TERM(I)= 0.5*(extended_WORK(extended_index)+ ADVPGD1E.307
& extended_WORK(extended_index-1)) ADVPGD1E.308
ENDDO ADVPGD1E.309
ENDIF ADVPGD1E.310
ADVPGD1E.311
*ENDIF ADVPGD1E.312
ADVPGD1E.314
CL ADVPGD1E.315
CL--------------------------------------------------------------------- ADVPGD1E.316
CL SECTION 2. CALCULATE V_TERM IN EQUATION (35). ADVPGD1E.317
CL--------------------------------------------------------------------- ADVPGD1E.318
ADVPGD1E.319
C---------------------------------------------------------------------- ADVPGD1E.320
CL SECTION 2.1 CALCULATE TERM V D(FIELD)/D(PHI). ADVPGD1E.321
C---------------------------------------------------------------------- ADVPGD1E.322
ADVPGD1E.323
C CALCULATE TERM AT ALL POINTS EXCEPT FIRST AND STORE IN WORK. ADVPGD1E.324
ADVPGD1E.325
! Calculate WORK at the Southern halo too. This is needed for the ADVPGD1E.341
! computation of the Southern row ADVPGD1E.342
ADVPGD1E.343
DO I=extended_START_POINT_NO_HALO-2*extended_ROW_LENGTH, ADVPGD1E.344
& extended_END_P_POINT_NO_HALO+extended_ROW_LENGTH ADVPGD1E.345
extended_WORK(I)=0.5*(V(I,K)+V(I-1,K))*LATITUDE_STEP_INVERSE* ADVPGD1E.346
& (extended_FIELD(I,K)-extended_FIELD(I+extended_ROW_LENGTH,K)) ADVPGD1E.347
ENDDO ADVPGD1E.348
ADVPGD1E.349
ADVPGD1E.352
C---------------------------------------------------------------------- ADVPGD1E.353
CL SECTION 2.2 CALCULATE V ADVECTION TERM IN EQUATION (35). ADVPGD1E.354
CL IF L_SECOND = TRUE PERFORM SECOND ORDER ADVECTION ADVPGD1E.355
CL ONLY. ADVPGD1E.356
C---------------------------------------------------------------------- ADVPGD1E.357
ADVPGD1E.358
*IF DEF,GLOBAL ADVPGD1E.398
C GLOBAL MODEL. ADVPGD1E.399
! Calculate all values except on rows next to poles and next to the ADVPGD1E.400
! processor interfaces ADVPGD1E.401
ADVPGD1E.402
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO ADVPGD1E.403
extended_index=extended_address(I) ADVPGD1E.404
ADVPGD1E.405
V_TERM(I) = (1.0+NUY(I,K))*0.5* ADVPGD1E.406
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.407
& + extended_WORK(extended_index)) ADVPGD1E.408
& - NUY(I,K) *0.5* ADVPGD1E.409
& (extended_WORK(extended_index+extended_ROW_LENGTH) ADVPGD1E.410
& + extended_WORK(extended_index-2*extended_ROW_LENGTH)) ADVPGD1E.411
ENDDO ADVPGD1E.412
*IF DEF,MPP,AND,DEF,T3E ADVPGD1E.413
c ADVPGD1E.414
c--for MPP Code, check that we have enough processors ADVPGD1E.415
if(nproc_x.eq.1 .or. nproc_y.eq.1) then ADVPGD1E.416
*ENDIF ADVPGD1E.417
ADVPGD1E.418
IF (at_top_of_LPG) THEN ADVPGD1E.419
! North Pole Rows ADVPGD1E.420
! We want to advect across the pole - which requires us to know the ADVPGD1E.421
! values on the opposite side of the pole. To do this we rotate the ADVPGD1E.422
! polar row by half a row in a work array - so each point in the ADVPGD1E.423
! original array matches its opposite point in the rotated array ADVPGD1E.424
ADVPGD1E.425
DO I=1,ROW_LENGTH ADVPGD1E.426
! rot_work(I)=extended_WORK(halo_4th*extended_ROW_LENGTH+I+1) ADVPGD1E.427
rot_work(I)= ADVPGD1E.428
& extended_WORK(extended_address(TOP_ROW_START+I-1)) ADVPGD1E.429
ENDDO ADVPGD1E.430
ADVPGD1E.431
CALL GCG_RVECSHIFT(ROW_LENGTH,ROW_LENGTH-2*EW_Halo, ADVPGD1E.432
& halo_4th,1, ADVPGD1E.433
& GLOBAL_ROW_LENGTH/2,.TRUE.,rot_work, ADVPGD1E.434
& GC_ROW_GROUP,info) ADVPGD1E.435
ADVPGD1E.436
DO I=1,ROW_LENGTH ADVPGD1E.437
IK=START_POINT_NO_HALO-1+I ! point in row beneath polar row ADVPGD1E.438
extended_index=extended_address(IK) ADVPGD1E.439
! extended_index=(Offy+2)*extended_ROW_LENGTH +I+1 ADVPGD1E.440
! ! same point in extended field ADVPGD1E.441
ADVPGD1E.442
! Calculate V_TERM in row beneath polar row ADVPGD1E.443
V_TERM(IK)= (1.0+NUY(IK,K))*0.5* ADVPGD1E.444
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.445
& + extended_WORK(extended_index)) ADVPGD1E.446
& - NUY(IK,K) *0.5* ADVPGD1E.447
& (extended_WORK(extended_index+extended_ROW_LENGTH) ADVPGD1E.448
& + rot_work(I)) ADVPGD1E.449
ADVPGD1E.450
! Calculate V_TERM in polar row ADVPGD1E.451
V_TERM(IK-ROW_LENGTH) = (1.0+NUY(IK,K))*0.5* ADVPGD1E.452
& extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.453
& - NUY(IK,K)*0.5*extended_WORK(extended_index) ADVPGD1E.454
ADVPGD1E.455
ENDDO ADVPGD1E.456
ADVPGD1E.457
ENDIF ! (attop) ADVPGD1E.458
ADVPGD1E.459
IF (at_base_of_LPG) THEN ADVPGD1E.460
! South Pole Rows : similar code to that for North Pole ADVPGD1E.461
ADVPGD1E.462
DO I=1,ROW_LENGTH ADVPGD1E.463
extended_index= ADVPGD1E.464
& extended_address(P_BOT_ROW_START-ROW_LENGTH+I-1) ADVPGD1E.465
! extended_index=extended_P_FIELD- ADVPGD1E.466
! & (Offy+3)*extended_ROW_LENGTH +I+1 ADVPGD1E.467
rot_work(I)=extended_WORK(extended_index) ADVPGD1E.468
ENDDO ADVPGD1E.469
ADVPGD1E.470
CALL GCG_RVECSHIFT(ROW_LENGTH,ROW_LENGTH-2*EW_Halo, ADVPGD1E.471
& halo_4th,1, ADVPGD1E.472
& GLOBAL_ROW_LENGTH/2,.TRUE.,rot_work, ADVPGD1E.473
& GC_ROW_GROUP,info) ADVPGD1E.474
ADVPGD1E.475
DO I=1,ROW_LENGTH ADVPGD1E.476
IJ=END_P_POINT_NO_HALO-ROW_LENGTH+I ! row above South Pole ADVPGD1E.477
extended_index=extended_address(IJ) ADVPGD1E.478
! IJ=P_FIELD-(Offy+2)*ROW_LENGTH+I ! row above South Pole ADVPGD1E.479
! extended_index=extended_P_FIELD- ADVPGD1E.480
! & (Offy+3)*extended_ROW_LENGTH +I+1 ADVPGD1E.481
ADVPGD1E.482
! Calculate V_TERM in row above polar row ADVPGD1E.483
V_TERM(IJ)= (1.0+NUY(IJ,K))*0.5* ADVPGD1E.484
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.485
& + extended_WORK(extended_index)) ADVPGD1E.486
& - NUY(IJ,K) *0.5* ADVPGD1E.487
& (rot_work(I)+ ADVPGD1E.488
& extended_WORK(extended_index-2*extended_ROW_LENGTH)) ADVPGD1E.489
ADVPGD1E.490
! Calculate V_TERM in polar row ADVPGD1E.491
V_TERM(IJ+ROW_LENGTH) = (1.0+NUY(IJ,K))*0.5* ADVPGD1E.492
& extended_WORK(extended_index) - NUY(IJ,K)*0.5* ADVPGD1E.493
& extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.494
ADVPGD1E.495
ENDDO ADVPGD1E.496
ADVPGD1E.497
ENDIF ! (atbase) ADVPGD1E.498
*IF DEF,MPP,AND,DEF,T3E ADVPGD1E.499
c ADVPGD1E.500
else ! MPP/T3E and only 1 processor along either direction ADVPGD1E.501
c ADVPGD1E.502
call barrier() ADVPGD1E.503
c ADVPGD1E.504
IF (at_top_of_LPG) THEN ADVPGD1E.505
! North Pole Rows ADVPGD1E.506
ADVPGD1E.507
DO I=1,ROW_LENGTH ADVPGD1E.508
! rot_work(I)=extended_WORK(halo_4th*extended_ROW_LENGTH+I+1) ADVPGD1E.509
rot_work(I)= ADVPGD1E.510
& extended_WORK(extended_address(TOP_ROW_START+I-1)) ADVPGD1E.511
ENDDO ADVPGD1E.512
ENDIF ! (attop) ADVPGD1E.513
ADVPGD1E.514
IF (at_base_of_LPG) THEN ADVPGD1E.515
! South Pole Rows : similar code to that for North Pole ADVPGD1E.516
ADVPGD1E.517
DO I=1,ROW_LENGTH ADVPGD1E.518
extended_index= ADVPGD1E.519
& extended_address(P_BOT_ROW_START-ROW_LENGTH+I-1) ADVPGD1E.520
! extended_index=extended_P_FIELD- ADVPGD1E.521
! & (Offy+3)*extended_ROW_LENGTH +I+1 ADVPGD1E.522
rot_work(I)=extended_WORK(extended_index) ADVPGD1E.523
ENDDO ADVPGD1E.524
ENDIF ! (atbase) ADVPGD1E.525
c ADVPGD1E.526
call barrier() ADVPGD1E.527
c ADVPGD1E.528
c--process North and South Rows together ADVPGD1E.529
IF (at_top_of_LPG .or. at_base_of_LPG) THEN ADVPGD1E.530
c--work out the PE at the start of my Row ADVPGD1E.531
my_row_pe=(mype/nproc_x)*nproc_x ADVPGD1E.532
g_start(1)=1 ADVPGD1E.533
c--find the global start addresses for PE's in my row ADVPGD1E.534
do i=2, nproc_x+1 ADVPGD1E.535
g_start(i)=g_start(i-1)+g_blsizep(1,i-2) ADVPGD1E.536
end do ADVPGD1E.537
c write(0,*) my_pe(), (g_start(i), i=1, nproc_x+1) ADVPGD1E.538
c ADVPGD1E.539
c--set the global start address for the start of my exchange ADVPGD1E.540
g_new_start=g_start(mype-my_row_pe+1)+global_row_length/2 ADVPGD1E.541
c--set the length of the data to exchange ADVPGD1E.542
l_new_length=row_length-2*ew_halo ADVPGD1E.543
c--set the start address ADVPGD1E.544
l_iadd=halo_4th ADVPGD1E.545
c--loop until we have moved all the segments for this PE ADVPGD1E.546
1000 continue ADVPGD1E.547
c--check we not off the end ADVPGD1E.548
if(g_new_start.gt.glsize(1)) g_new_start= ADVPGD1E.549
2 g_new_start-glsize(1) ADVPGD1E.550
c--loop over the PE's in a row ADVPGD1E.551
do i=1, nproc_x ADVPGD1E.552
c--check if this glocal address is on the the current remote PE ADVPGD1E.553
if(g_new_start.ge.g_start(i) .and. ADVPGD1E.554
2 g_new_start.lt.g_start(i+1)) then ADVPGD1E.555
c--compute the new local address on the remote PE ADVPGD1E.556
l_rem_iadd=g_new_start-g_start(i) ADVPGD1E.557
c--compute the number of words to move on this get ADVPGD1E.558
current_length=min(l_new_length, ADVPGD1E.559
2 g_start(i+1)-g_new_start) ADVPGD1E.560
c write(0,*) my_pe(), ' fetch ', current_length, ADVPGD1E.561
c 2 ' from PE ',i-1, ' from ',l_rem_iadd+halo_4th, ADVPGD1E.562
c 3 ' to ', l_iadd ADVPGD1E.563
c--get the data ADVPGD1E.564
call shmem_get(rot_work_out(l_iadd), ADVPGD1E.565
2 rot_work(l_rem_iadd+halo_4th), current_length, ADVPGD1E.566
3 my_row_pe+i-1) ADVPGD1E.567
ADVPGD1E.568
c--update the global address and local addresses and lengths ADVPGD1E.569
g_new_start=g_new_start+current_length ADVPGD1E.570
l_iadd=l_iadd+current_length ADVPGD1E.571
l_new_length=l_new_length-current_length ADVPGD1E.572
c--check if we have finished ADVPGD1E.573
if(l_new_length.gt.0) goto 1000 ADVPGD1E.574
goto 1100 ADVPGD1E.575
endif ADVPGD1E.576
end do ADVPGD1E.577
write(0,*)'PE ', my_pe(), ' is Lost in ADV_P_GD ', ADVPGD1E.578
2 l_new_length, current_length, l_rem_iadd+halo_4th, l_iadd, ADVPGD1E.579
3 g_new_start, (g_start(i), i=1, nproc_x+1) ADVPGD1E.580
call abort('Lost in ADV_P_GD') ADVPGD1E.581
ADVPGD1E.582
1100 continue ADVPGD1E.583
rot_work_out(1)=rot_work(1) ADVPGD1E.584
rot_work_out(row_length)=rot_work(row_length) ADVPGD1E.585
c write(0,*) my_pe(), (rot_work_out(i), i=1, ADVPGD1E.586
c 2 row_length) ADVPGD1E.587
ADVPGD1E.588
ENDIF ! (at_top_of_LPG .or. at_base_of_LPG) ADVPGD1E.589
c ADVPGD1E.590
IF (at_top_of_LPG) THEN ADVPGD1E.591
! North Pole ADVPGD1E.592
ADVPGD1E.593
DO I=1,ROW_LENGTH ADVPGD1E.594
IK=START_POINT_NO_HALO-1+I ! point in row beneath polar row ADVPGD1E.595
extended_index=extended_address(IK) ADVPGD1E.596
! extended_index=(Offy+2)*extended_ROW_LENGTH +I+1 ADVPGD1E.597
! ! same point in extended field ADVPGD1E.598
ADVPGD1E.599
! Calculate V_TERM in row beneath polar row ADVPGD1E.600
V_TERM(IK)= (1.0+NUY(IK,K))*0.5* ADVPGD1E.601
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.602
& + extended_WORK(extended_index)) ADVPGD1E.603
& - NUY(IK,K) *0.5* ADVPGD1E.604
& (extended_WORK(extended_index+extended_ROW_LENGTH) ADVPGD1E.605
& + rot_work_out(I)) ADVPGD1E.606
ADVPGD1E.607
! Calculate V_TERM in polar row ADVPGD1E.608
V_TERM(IK-ROW_LENGTH) = (1.0+NUY(IK,K))*0.5* ADVPGD1E.609
& extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.610
& - NUY(IK,K)*0.5*extended_WORK(extended_index) ADVPGD1E.611
ADVPGD1E.612
ENDDO ADVPGD1E.613
ENDIF ! (IF at_top_of_LPG) ADVPGD1E.614
c ADVPGD1E.615
IF (at_base_of_LPG) THEN ADVPGD1E.616
! South Pole ADVPGD1E.617
ADVPGD1E.618
DO I=1,ROW_LENGTH ADVPGD1E.619
IJ=END_P_POINT_NO_HALO-ROW_LENGTH+I ! row above South Pole ADVPGD1E.620
extended_index=extended_address(IJ) ADVPGD1E.621
! IJ=P_FIELD-(Offy+2)*ROW_LENGTH+I ! row above South Pole ADVPGD1E.622
! extended_index=extended_P_FIELD- ADVPGD1E.623
! & (Offy+3)*extended_ROW_LENGTH +I+1 ADVPGD1E.624
ADVPGD1E.625
! Calculate V_TERM in row above polar row ADVPGD1E.626
V_TERM(IJ)= (1.0+NUY(IJ,K))*0.5* ADVPGD1E.627
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.628
& + extended_WORK(extended_index)) ADVPGD1E.629
& - NUY(IJ,K) *0.5* ADVPGD1E.630
& (rot_work_out(I)+ ADVPGD1E.631
& extended_WORK(extended_index-2*extended_ROW_LENGTH)) ADVPGD1E.632
ADVPGD1E.633
! Calculate V_TERM in polar row ADVPGD1E.634
V_TERM(IJ+ROW_LENGTH) = (1.0+NUY(IJ,K))*0.5* ADVPGD1E.635
& extended_WORK(extended_index) - NUY(IJ,K)*0.5* ADVPGD1E.636
& extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.637
ADVPGD1E.638
ENDDO ADVPGD1E.639
ENDIF ! (IF at_base_of_LPG) ADVPGD1E.640
c ADVPGD1E.641
endif ! Code for more then one processor in each direction ADVPGD1E.642
c ADVPGD1E.643
*ENDIF ADVPGD1E.644
ADVPGD1E.645
*ELSE ADVPGD1E.646
C LIMITED AREA MODEL. ADVPGD1E.647
! Calculate all values except on rows next to poles and next to the ADVPGD1E.648
! processor interfaces ADVPGD1E.649
ADVPGD1E.650
! Loop over field, missing top and bottom rows and halos ADVPGD1E.651
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO ADVPGD1E.652
extended_index=extended_address(I) ADVPGD1E.653
ADVPGD1E.654
V_TERM(I) = (1.0+NUY(I,K))*0.5* ADVPGD1E.655
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.656
& + extended_WORK(extended_index)) ADVPGD1E.657
& - NUY(I,K) *0.5* ADVPGD1E.658
& (extended_WORK(extended_index+extended_ROW_LENGTH) ADVPGD1E.659
& + extended_WORK(extended_index-2*extended_ROW_LENGTH)) ADVPGD1E.660
ENDDO ADVPGD1E.661
ADVPGD1E.662
ADVPGD1E.663
C CALCULATE VALUES ON SLICES NEXT TO BOUNDARIES AS SECOND ORDER. ADVPGD1E.664
ADVPGD1E.665
IF (at_top_of_LPG) THEN ADVPGD1E.666
! Loop over row beneath top row, missing halos ADVPGD1E.667
DO I=START_POINT_NO_HALO+FIRST_ROW_PT-1, ADVPGD1E.668
& START_POINT_NO_HALO+LAST_ROW_PT-1 ADVPGD1E.669
extended_index=extended_address(I) ADVPGD1E.670
ADVPGD1E.671
V_TERM(I)=0.5* ADVPGD1E.672
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.673
& + extended_WORK(extended_index)) ADVPGD1E.674
ENDDO ADVPGD1E.675
ENDIF ADVPGD1E.676
ADVPGD1E.677
IF (at_base_of_LPG) THEN ADVPGD1E.678
! Loop over row above bottom row, missing halos ADVPGD1E.679
DO I=END_P_POINT_NO_HALO-ROW_LENGTH+FIRST_ROW_PT, ADVPGD1E.680
& END_P_POINT_NO_HALO-ROW_LENGTH+LAST_ROW_PT ADVPGD1E.681
extended_index=extended_address(I) ADVPGD1E.682
V_TERM(I)=0.5* ADVPGD1E.683
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVPGD1E.684
& + extended_WORK(extended_index)) ADVPGD1E.685
ENDDO ADVPGD1E.686
ENDIF ADVPGD1E.687
ADVPGD1E.688
*ENDIF ADVPGD1E.689
ADVPGD1E.691
CL ADVPGD1E.692
CL--------------------------------------------------------------------- ADVPGD1E.693
CL SECTION 3. CALCULATE VERTICAL FLUX AND COMBINE WITH U AND V ADVPGD1E.694
CL TERMS TO FORM INCREMENT. ADVPGD1E.695
CL--------------------------------------------------------------------- ADVPGD1E.696
ADVPGD1E.697
CL VERTICAL FLUX ON INPUT IS .5*TIMESTEP*ETADOT*D(FIELD)/D(ETA) ADVPGD1E.698
CL AT LEVEL K-1/2. AT THE END OF THIS SECTION IT IS THE SAME ADVPGD1E.699
CL QUANTITY BUT AT LEVEL K+1/2. ADVPGD1E.700
ADVPGD1E.701
! Loop over field, missing top and bottom rows and halos ADVPGD1E.702
if(k.ne.1.and.k.ne.P_LEVELS)then ADVPGD1E.703
ADVPGD1E.704
cdir$ unroll4 ADVPGD1E.705
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO ADVPGD1E.706
SCALAR1 = .5 * ADVECTION_TIMESTEP * ADVPGD1E.707
* ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) ADVPGD1E.708
SCALAR2 = WORK(I) ADVPGD1E.709
FIELD_INC(I,K) = SCALAR1 +SCALAR2 ADVPGD1E.710
IF (LWHITBROM) FIELD_INC(I,K) = FIELD_INC(I,K) ADVPGD1E.711
* + FIELD(I,K)*BRSP(I,K) ADVPGD1E.712
WORK(I)=SCALAR1 ADVPGD1E.713
ENDDO ADVPGD1E.714
else if(k.eq.1) then ADVPGD1E.721
cdir$ unroll4 ADVPGD1E.722
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO ADVPGD1E.723
SCALAR1 = .5 * ADVECTION_TIMESTEP * ADVPGD1E.724
* ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) ADVPGD1E.725
FIELD_INC(I,K) = SCALAR1 ADVPGD1E.726
IF (LWHITBROM) FIELD_INC(I,K) = FIELD_INC(I,K) ADVPGD1E.727
* + FIELD(I,K)*BRSP(I,K) ADVPGD1E.728
WORK(I)=SCALAR1 ADVPGD1E.729
END DO ADVPGD1E.730
else if(k.eq.P_LEVELS) then ADVPGD1E.737
cdir$ unroll4 ADVPGD1E.738
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO ADVPGD1E.739
SCALAR2 = WORK(I) ADVPGD1E.740
FIELD_INC(I,K) = SCALAR2 ADVPGD1E.741
IF (LWHITBROM) FIELD_INC(I,K) = FIELD_INC(I,K) ADVPGD1E.742
* + FIELD(I,K)*BRSP(I,K) ADVPGD1E.743
END DO ADVPGD1E.744
endif ! if(k.ne.1.and.k.ne.P_LEVELS)then APB3F405.216
cdir$ unroll4 ADVPGD1E.745
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO ADVPGD1E.746
FIELD_INC(I,K) = FIELD_INC(I,K) + ADVPGD1E.747
* ADVECTION_TIMESTEP * SEC_P_LATITUDE(I) * ADVPGD1E.748
* (U_TERM(I)+V_TERM(I)) ADVPGD1E.749
ENDDO ADVPGD1E.750
ADVPGD1E.752
*IF DEF,GLOBAL ADVPGD1E.753
if(k.ne.1.and.k.ne.P_LEVELS)then ADVPGD1E.754
ADVPGD1E.755
IF (at_top_of_LPG) THEN ADVPGD1E.756
! North Pole Flux ADVPGD1E.757
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB3F405.217
SCALAR1 = 0.5 * ADVECTION_TIMESTEP * ADVPGD1E.759
& ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) ADVPGD1E.760
SCALAR2 = WORK(I) ADVPGD1E.761
FIELD_INC(I,K) = SCALAR1 + SCALAR2 ADVPGD1E.762
ADVPGD1E.763
IF (LWHITBROM) ADVPGD1E.764
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) ADVPGD1E.765
WORK(I)=SCALAR1 ADVPGD1E.766
ENDDO ADVPGD1E.767
ENDIF ! (at_top_of_LPG) ADVPGD1E.772
IF (at_base_of_LPG) THEN ADVPGD1E.773
! South Pole Flux ADVPGD1E.774
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 APB3F405.218
SCALAR1 = 0.5 * ADVECTION_TIMESTEP * ADVPGD1E.776
& ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) ADVPGD1E.777
SCALAR2 = WORK(I) ADVPGD1E.778
FIELD_INC(I,K) = SCALAR1 + SCALAR2 ADVPGD1E.779
ADVPGD1E.780
IF (LWHITBROM) ADVPGD1E.781
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) ADVPGD1E.782
WORK(I)=SCALAR1 ADVPGD1E.783
ENDDO ADVPGD1E.784
ENDIF ! (at_base_of_LPG) ADVPGD1E.789
else if(k.eq.1)then ADVPGD1E.790
IF (at_top_of_LPG) THEN ADVPGD1E.791
! North Pole Flux ADVPGD1E.792
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB3F405.219
SCALAR1 = 0.5 * ADVECTION_TIMESTEP * ADVPGD1E.794
& ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) ADVPGD1E.795
FIELD_INC(I,K) = SCALAR1 ADVPGD1E.796
ADVPGD1E.797
IF (LWHITBROM) ADVPGD1E.798
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) ADVPGD1E.799
WORK(I)=SCALAR1 ADVPGD1E.800
ENDDO ADVPGD1E.801
ENDIF ! (at_top_of_LPG) ADVPGD1E.806
IF (at_base_of_LPG) THEN ADVPGD1E.807
! North Pole Flux & South Pole Flux ADVPGD1E.808
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 APB3F405.220
SCALAR1 = 0.5 * ADVECTION_TIMESTEP * ADVPGD1E.810
& ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) ADVPGD1E.811
FIELD_INC(I,K) = SCALAR1 ADVPGD1E.812
ADVPGD1E.813
IF (LWHITBROM) ADVPGD1E.814
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) ADVPGD1E.815
WORK(I)=SCALAR1 ADVPGD1E.816
ENDDO ADVPGD1E.817
ENDIF ! (at_base_of_LPG) ADVPGD1E.822
else if(k.eq.P_LEVELS) then ADVPGD1E.823
IF (at_top_of_LPG) THEN ADVPGD1E.824
! North Pole Flux ADVPGD1E.825
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB3F405.221
SCALAR2 = WORK(I) ADVPGD1E.827
FIELD_INC(I,K) = SCALAR2 ADVPGD1E.828
ADVPGD1E.829
IF (LWHITBROM) ADVPGD1E.830
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) ADVPGD1E.831
ENDDO ADVPGD1E.832
ENDIF ! (at_top_of_LPG) ADVPGD1E.837
IF (at_base_of_LPG) THEN ADVPGD1E.838
! South Pole Flux ADVPGD1E.839
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 APB3F405.222
SCALAR2 = WORK(I) ADVPGD1E.841
FIELD_INC(I,K) = SCALAR2 ADVPGD1E.842
ADVPGD1E.843
IF (LWHITBROM) ADVPGD1E.844
& FIELD_INC(I,K) = FIELD_INC(I,K)+FIELD(I,K)*BRSP(I,K) ADVPGD1E.845
ENDDO ADVPGD1E.846
ENDIF ! (at_base_of_LPG) APB3F405.223
endif ! if(k.ne.1.and.k.ne.P_LEVELS) APB3F405.224
IF (at_top_of_LPG) THEN APB3F405.225
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB3F405.226
FIELD_INC(I,K) = FIELD_INC(I,K) + APB3F405.227
* ADVECTION_TIMESTEP * SEC_P_LATITUDE(I) * V_TERM(I) APB3F405.228
ENDDO APB3F405.229
ENDIF ! (at_top_of_LPG) APB3F405.230
IF (at_base_of_LPG) THEN APB3F405.231
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 APB3F405.232
FIELD_INC(I,K) = FIELD_INC(I,K) + ADVPGD1E.848
* ADVECTION_TIMESTEP * SEC_P_LATITUDE(I) * V_TERM(I) ADVPGD1E.849
ENDDO ADVPGD1E.850
ENDIF ! (at_base_of_LPG) ADVPGD1E.851
*ENDIF ADVPGD1E.853
ADVPGD1E.854
*IF -DEF,GLOBAL ADVPGD1E.855
ADVPGD1E.856
CL LIMITED AREA MODEL SET BOUNDARY INCREMENTS ADVPGD1E.857
CL TO ZERO. ADVPGD1E.858
ADVPGD1E.859
IF (at_left_of_LPG) THEN ADVPGD1E.860
DO I=START_POINT_NO_HALO+FIRST_ROW_PT-1, ADVPGD1E.861
& END_P_POINT_NO_HALO,ROW_LENGTH ADVPGD1E.862
FIELD_INC(I,K)=0. ADVPGD1E.863
ENDDO ADVPGD1E.864
ENDIF ADVPGD1E.865
ADVPGD1E.866
IF (at_right_of_LPG) THEN ADVPGD1E.867
DO I=START_POINT_NO_HALO+LAST_ROW_PT-1, ADVPGD1E.868
& END_P_POINT_NO_HALO,ROW_LENGTH ADVPGD1E.869
FIELD_INC(I,K)=0. ADVPGD1E.870
ENDDO ADVPGD1E.871
ENDIF ADVPGD1E.872
ADVPGD1E.873
*ENDIF ADVPGD1E.874
ENDDO !DO K=1,P_LEVELS APB3F405.233
APB3F405.234
ENDIF !IF(L_SECOND) APB3F405.235
ADVPGD1E.876
CL END OF ROUTINE ADV_P_GD ADVPGD1E.877
ADVPGD1E.878
RETURN ADVPGD1E.879
END ADVPGD1E.880
*ENDIF ADVPGD1E.881
*ENDIF ADVPGD1E.882