SUBROUTINE ADV_U_GD 12ADVUGD1E.51
1 (P_LEVELS,FIELD,U,V, ADVUGD1E.52
1 ETADOT, ADVUGD1E.53
2 SEC_U_LATITUDE,FIELD_INC,NUX,NUY,U_FIELD, ADVUGD1E.54
3 ROW_LENGTH, ADVUGD1E.55
*CALL ARGFLDPT 
ADVUGD1E.56
4 ADVECTION_TIMESTEP, ADVUGD1E.57
5 LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ADVUGD1E.58
6 SEC_P_LATITUDE,BRSP, ADVUGD1E.59
7 L_SECOND,LWHITBROM, ADVUGD1E.60
& extended_FIELD,extended_U_FIELD, ADVUGD1E.61
& extended_address) ADVUGD1E.62
ADVUGD1E.63
IMPLICIT NONE ADVUGD1E.64
ADVUGD1E.65
INTEGER ADVUGD1E.66
* P_LEVELS ADVUGD1E.67
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID ADVUGD1E.68
&, extended_U_FIELD !IN DIMENSION of U fields with extra halo ADVUGD1E.69
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW ADVUGD1E.70
ADVUGD1E.71
! All TYPFLDPT arguments are intent IN ADVUGD1E.72
*CALL TYPFLDPT ADVUGD1E.73
ADVUGD1E.74
REAL ADVUGD1E.75
* U(extended_U_FIELD,P_LEVELS) !IN ADVECTING U FIELD MASS-WEIGHTED ADVUGD1E.76
* ! HELD AT P POINTS. FIRST POINT OF FIELD ADVUGD1E.77
* ! IS FIRST P POINT ON SECOND ROW OF P-GRID. ADVUGD1E.78
*,V(extended_U_FIELD,P_LEVELS) !IN ADVECTING V FIELD MASS-WEIGHTED ADVUGD1E.79
* ! HELD AT P POINTS. FIRST POINT OF FIELD ADVUGD1E.80
* ! IS FIRST P POINT ON SECOND ROW OF P-GRID. ADVUGD1E.81
*,ETADOT(U_FIELD,P_LEVELS)!IN ADVECTING VERTICAL VELOC AT K+1/2, ADVUGD1E.82
* ! MASS-WEIGHTED. ADVUGD1E.83
*,FIELD(U_FIELD,P_LEVELS) !IN FIELD TO BE ADVECTED. ADVUGD1E.84
*,NUX(U_FIELD,P_LEVELS) !IN HOLDS PARAMETER NU FOR EAST-WEST ADVE ADVUGD1E.85
*,NUY(U_FIELD,P_LEVELS) !IN HOLDS PARAMETER NU FOR NORTH-SOUTH AD ADVUGD1E.86
*,SEC_U_LATITUDE(U_FIELD) !IN HOLDS 1/COS(PHI) AT U POINTS. ADVUGD1E.87
*,SEC_P_LATITUDE(U_FIELD) !IN HOLDS 1/COS(PHI) AT P POINTS. ADVUGD1E.88
*,ADVECTION_TIMESTEP !IN ADVUGD1E.89
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) ADVUGD1E.90
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) ADVUGD1E.91
ADVUGD1E.92
REAL ADVUGD1E.93
* BRSP(U_FIELD,P_LEVELS) !IN BRSP TERM AT LEVEL+1/2 APB3F405.238
* ! (SEE DOC.PAPER NO 10) APB3F405.239
ADVUGD1E.96
REAL ADVUGD1E.97
* FIELD_INC(U_FIELD,P_LEVELS) !OUT HOLDS INCREMENT TO FIELD. ADVUGD1E.98
ADVUGD1E.99
REAL ADVUGD1E.100
* VERTICAL_FLUX(U_FIELD) !INOUT HOLDS VERTICAL FLUX OF FIELD ADVUGD1E.101
* ! BETWEEN TWO LEVELS. ADVUGD1E.102
ADVUGD1E.103
REAL ADVUGD1E.104
& extended_FIELD(extended_U_FIELD,P_LEVELS) ! IN field to be advect ADVUGD1E.105
! ! extra halos for 4th order ADVUGD1E.106
INTEGER extended_address(U_FIELD) ADVUGD1E.107
ADVUGD1E.108
C LOGICAL VARIABLE ADVUGD1E.109
LOGICAL ADVUGD1E.110
* L_SECOND ! SET TO TRUE IF NU_BASIC IS ZERO. ADVUGD1E.111
* ,LWHITBROM ! Switch for White & Bromley terms ADVUGD1E.112
C ADVUGD1E.113
ADVUGD1E.114
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- ADVUGD1E.115
C DEFINE LOCAL ARRAYS: 3 ARE REQUIRED ADVUGD1E.116
ADVUGD1E.117
REAL ADVUGD1E.118
* WORK(U_FIELD) ! GENERAL WORK-SPACE. ADVUGD1E.119
*,U_TERM(U_FIELD) ! HOLDS U ADVECTION TERM FROM EQUATION (37) ADVUGD1E.120
*,V_TERM(U_FIELD) ! HOLDS V ADVECTION TERM FROM EQUATION (37) ADVUGD1E.121
C*--------------------------------------------------------------------- ADVUGD1E.122
C DEFINE LOCAL VARIABLES ADVUGD1E.123
ADVUGD1E.124
C REAL SCALARS ADVUGD1E.125
REAL ADVUGD1E.126
* SCALAR1,SCALAR2 ADVUGD1E.127
ADVUGD1E.128
C COUNT VARIABLES FOR DO LOOPS ETC. ADVUGD1E.129
INTEGER ADVUGD1E.130
* I,J,K ADVUGD1E.131
ADVUGD1E.132
! Work space and scalars for the MPP Fourth Order Advection ADVUGD1E.133
INTEGER extended_index, ! index for position in extended array ADVUGD1E.134
& extended_START_POINT_NO_HALO, ADVUGD1E.135
! ! start pos in extended array ADVUGD1E.136
& extended_END_U_POINT_NO_HALO, ADVUGD1E.137
! ! end pos in extended array ADVUGD1E.138
& extended_ROW_LENGTH,! row length of extended array ADVUGD1E.139
& I_start,I_end ! loop bounds for 4th order advection ADVUGD1E.140
ADVUGD1E.141
REAL ADVUGD1E.142
& extended_WORK(extended_U_FIELD) ! extended work space ADVUGD1E.143
ADVUGD1E.144
ADVUGD1E.145
C*L NO EXTERNAL SUBROUTINE CALLS:------------------------------------ ADVUGD1E.146
C*--------------------------------------------------------------------- ADVUGD1E.147
ADVUGD1E.148
CL MAXIMUM VECTOR LENGTH ASSUMED IS ADVUGD1E.149
CL END_U_POINT_NO_HALO-START_U_UPDATE+1 ADVUGD1E.150
CL--------------------------------------------------------------------- ADVUGD1E.151
IF(L_SECOND) THEN APB3F405.240
! SECOND ORDER ADEVCTION APB3F405.241
APB3F405.242
DO K=1,P_LEVELS APB3F405.243
APB3F405.244
CL--------------------------------------------------------------------- APB3F405.245
CL SECTION 1. CALCULATE U_TERM IN EQUATION (37). APB3F405.246
CL--------------------------------------------------------------------- APB3F405.247
APB3F405.248
C---------------------------------------------------------------------- APB3F405.249
CL SECTION 1.1 CALCULATE TERM U D(FIELD)/D(LAMDA). APB3F405.250
C---------------------------------------------------------------------- APB3F405.251
APB3F405.252
C---------------------------------------------------------------------- APB3F405.253
CL SECTION 1.2 CALCULATE U ADVECTION TERM IN EQUATION (37). APB3F405.254
CL IF L_SECOND=TRUE ONLY DO SECOND ORDER ADVECTION. APB3F405.255
C---------------------------------------------------------------------- APB3F405.256
APB3F405.257
CL APB3F405.258
CL--------------------------------------------------------------------- APB3F405.259
CL SECTION 2. CALCULATE V_TERM IN EQUATION (37). APB3F405.260
CL--------------------------------------------------------------------- APB3F405.261
APB3F405.262
C---------------------------------------------------------------------- APB3F405.263
CL SECTION 2.1 CALCULATE TERM V D(FIELD)/D(PHI). APB3F405.264
C---------------------------------------------------------------------- APB3F405.265
APB3F405.266
C---------------------------------------------------------------------- APB3F405.267
CL SECTION 2.2 CALCULATE V ADVECTION TERM IN EQUATION (37). APB3F405.268
CL IF L_SECOND=TRUE ONLY DO SECOND ORDER ADVECTION. APB3F405.269
C---------------------------------------------------------------------- APB3F405.270
APB3F405.271
CL APB3F405.272
CL--------------------------------------------------------------------- APB3F405.273
CL SECTION 3. CALCULATE VERTICAL FLUX AND COMBINE WITH U AND V APB3F405.274
CL TERMS TO FORM INCREMENT. APB3F405.275
CL--------------------------------------------------------------------- APB3F405.276
APB3F405.277
CL VERTICAL FLUX ON INPUT IS .5*TIMESTEP*ETADOT*D(FIELD)/D(ETA) APB3F405.278
CL AT LEVEL K-1/2. AT THE END OF THEIS SECTION IT IS THE SAME APB3F405.279
CL QUANTITY BUT AT LEVEL K+1/2. APB3F405.280
APB3F405.281
! Loop over field, missing top and bottom rows and halos APB3F405.282
APB3F405.283
IF(K.NE.1.AND.K.NE.P_LEVELS)THEN APB3F405.284
cdir$ unroll4 APB3F405.285
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 APB3F405.286
SCALAR1 = .5 * ADVECTION_TIMESTEP * APB3F405.287
* ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) APB3F405.288
SCALAR2 = WORK(I) APB3F405.289
WORK(I)=SCALAR1 APB3F405.290
FIELD_INC(I,K) = SCALAR1+SCALAR2 APB3F405.291
IF (LWHITBROM) THEN APB3F405.292
FIELD_INC(I,K) = FIELD_INC(I,K) APB3F405.293
* + FIELD(I,K)*BRSP(I,K) APB3F405.294
END IF APB3F405.295
ENDDO APB3F405.296
ELSE IF(K.EQ.1)THEN APB3F405.297
cdir$ unroll4 APB3F405.298
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 APB3F405.299
SCALAR1 = .5 * ADVECTION_TIMESTEP * APB3F405.300
* ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) APB3F405.301
WORK(I)=SCALAR1 APB3F405.302
FIELD_INC(I,K) = SCALAR1 APB3F405.303
IF (LWHITBROM) THEN APB3F405.304
FIELD_INC(I,K) = FIELD_INC(I,K) APB3F405.305
* + FIELD(I,K)*BRSP(I,K) APB3F405.306
END IF APB3F405.307
ENDDO APB3F405.308
APB3F405.309
ELSE IF(K.EQ.P_LEVELS) THEN APB3F405.310
cdir$ unroll4 APB3F405.311
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 APB3F405.312
SCALAR2 = WORK(I) APB3F405.313
FIELD_INC(I,K) = SCALAR2 APB3F405.314
IF (LWHITBROM) THEN APB3F405.315
FIELD_INC(I,K) = FIELD_INC(I,K) APB3F405.316
* + FIELD(I,K)*BRSP(I,K) APB3F405.317
END IF APB3F405.318
ENDDO APB3F405.319
ENDIF !IF(K.EQ.P_LEVELS) APB3F405.320
APB3F405.321
DO I=START_POINT_NO_HALO+1,END_U_POINT_NO_HALO-1 APB3F405.322
FIELD_INC(I,K) = .25*ADVECTION_TIMESTEP * SEC_U_LATITUDE(I) * APB3F405.323
* (LONGITUDE_STEP_INVERSE* APB3F405.324
& ((U(I+1,K)+U(I+1-ROW_LENGTH,K))* APB3F405.325
& (FIELD(I+1,K) - FIELD(I,K))+ APB3F405.326
& (U(I,K)+U(I-ROW_LENGTH,K))* APB3F405.327
& (FIELD(I,K) - FIELD(I-1,K))) APB3F405.328
& + APB3F405.329
& LATITUDE_STEP_INVERSE* APB3F405.330
& ((V(I-ROW_LENGTH,K)+V(I+1-ROW_LENGTH,K))* APB3F405.331
& (FIELD(I-ROW_LENGTH,K)-FIELD(I,K)) APB3F405.332
& +(V(I,K)+V(I+1,K))* APB3F405.333
& (FIELD(I,K)-FIELD(I+ROW_LENGTH,K)))) APB3F405.334
* + FIELD_INC(I,K) APB3F405.335
ENDDO APB3F405.336
APB3F405.337
FIELD_INC(END_U_POINT_NO_HALO,K)=0.0 APB3F405.338
APB3F405.339
*IF -DEF,GLOBAL APB3F405.340
APB3F405.341
CL LIMITED AREA MODEL SET BOUNDARY INCREMENTS TO ZERO. APB3F405.342
APB3F405.343
IF (at_left_of_LPG) THEN APB3F405.344
DO I=START_POINT_NO_HALO+FIRST_ROW_PT-1, APB3F405.345
& END_U_POINT_NO_HALO,ROW_LENGTH APB3F405.346
FIELD_INC(I,K)=0.0 APB3F405.347
ENDDO APB3F405.348
ENDIF APB3F405.349
APB3F405.350
IF (at_right_of_LPG) THEN APB3F405.351
DO I=START_POINT_NO_HALO+LAST_ROW_PT-2, APB3F405.352
& END_U_POINT_NO_HALO,ROW_LENGTH APB3F405.353
FIELD_INC(I,K)=0.0 APB3F405.354
FIELD_INC(I+1,K)=0.0 APB3F405.355
ENDDO APB3F405.356
ENDIF APB3F405.357
APB3F405.358
*ENDIF APB3F405.359
APB3F405.360
ENDDO !DO K=1,P_LEVELS APB3F405.361
APB3F405.362
ELSE !IF(L_SECOND) APB3F405.363
! FOURTH ORDER ADEVCTION APB3F405.364
ADVUGD1E.152
! Calculate indexes in extended_arrays ADVUGD1E.154
ADVUGD1E.155
extended_ROW_LENGTH=ROW_LENGTH+2*extra_EW_Halo ADVUGD1E.156
ADVUGD1E.157
extended_START_POINT_NO_HALO= ADVUGD1E.158
& extended_address(START_POINT_NO_HALO) ADVUGD1E.159
ADVUGD1E.160
extended_END_U_POINT_NO_HALO= ADVUGD1E.161
& extended_address(END_U_POINT_NO_HALO) ADVUGD1E.162
ADVUGD1E.163
ADVUGD1E.165
DO K=1,P_LEVELS ADVUGD1E.166
ADVUGD1E.167
CL--------------------------------------------------------------------- ADVUGD1E.168
CL SECTION 1. CALCULATE U_TERM IN EQUATION (37). ADVUGD1E.169
CL--------------------------------------------------------------------- ADVUGD1E.170
ADVUGD1E.171
C---------------------------------------------------------------------- ADVUGD1E.172
CL SECTION 1.1 CALCULATE TERM U D(FIELD)/D(LAMDA). ADVUGD1E.173
C---------------------------------------------------------------------- ADVUGD1E.174
ADVUGD1E.175
C CALCULATE TERM AT ALL POINTS EXCEPT LAST AND STORE IN WORK. ADVUGD1E.176
ADVUGD1E.177
! Loop over extended field, missing top and bottom rows and halos rows ADVUGD1E.190
DO I=extended_START_POINT_NO_HALO-1, ADVUGD1E.191
& extended_END_U_POINT_NO_HALO ADVUGD1E.192
extended_WORK(I) = 0.5*(U(I+1,K)+U(I+1-extended_ROW_LENGTH,K)) ADVUGD1E.193
& *LONGITUDE_STEP_INVERSE* ADVUGD1E.194
& (extended_FIELD(I+1,K)-extended_FIELD(I,K)) ADVUGD1E.195
ENDDO ADVUGD1E.196
ADVUGD1E.197
ADVUGD1E.200
C---------------------------------------------------------------------- ADVUGD1E.201
CL SECTION 1.2 CALCULATE U ADVECTION TERM IN EQUATION (37). ADVUGD1E.202
CL IF L_SECOND=TRUE ONLY DO SECOND ORDER ADVECTION. ADVUGD1E.203
C---------------------------------------------------------------------- ADVUGD1E.204
ADVUGD1E.205
ADVUGD1E.234
C LOOP OVER ALL POINTS BUT DON'T DO FIRST,SECOND AND LAST ON A ROW AS ADVUGD1E.235
C THEY NEED SPECIAL TREATMENT DUE TO FOURTH ORDER SCHEME. ADVUGD1E.236
ADVUGD1E.237
! Loop over field, missing top and bottom rows and halos, and ADVUGD1E.238
! first point. ADVUGD1E.239
DO 120 J=START_POINT_NO_HALO+1,END_U_POINT_NO_HALO-1 ADVUGD1E.240
! DO 120 J=START_POINT_NO_HALO+2,END_U_POINT_NO_HALO-1 ADVUGD1E.241
extended_index=extended_address(J) ADVUGD1E.242
ADVUGD1E.243
U_TERM(J) = (1.+NUX(J,K))*.5*(extended_WORK(extended_index)+ ADVUGD1E.244
& extended_WORK(extended_index-1)) ADVUGD1E.245
& -NUX(J,K) *.5*(extended_WORK(extended_index+1)+ ADVUGD1E.246
& extended_WORK(extended_index-2)) ADVUGD1E.247
120 CONTINUE ADVUGD1E.248
ADVUGD1E.249
*IF DEF,GLOBAL ADVUGD1E.250
U_TERM(START_POINT_NO_HALO)= U_TERM(START_POINT_NO_HALO+2) ADVUGD1E.251
! U_TERM(START_POINT_NO_HALO+1)= U_TERM(START_POINT_NO_HALO+2) ADVUGD1E.252
! U_TERM(END_U_POINT_NO_HALO)= U_TERM(END_U_POINT_NO_HALO-1) ADVUGD1E.253
ADVUGD1E.254
*ELSE ADVUGD1E.255
C LIMITED AREA MODEL. ADVUGD1E.256
C CALCULATE VALUES AT SECOND AND NEXT TO LAST POINTS ON A ROW. ADVUGD1E.257
C THESE VALUES ARE JUST SECOND ORDER. ADVUGD1E.258
ADVUGD1E.259
IF (at_left_of_LPG) THEN ADVUGD1E.260
! Do second point along each row ADVUGD1E.261
DO I=START_POINT_NO_HALO+FIRST_ROW_PT,END_U_POINT_NO_HALO, ADVUGD1E.262
& ROW_LENGTH ADVUGD1E.263
extended_index=extended_address(I) ADVUGD1E.264
ADVUGD1E.265
U_TERM(I)= 0.5*(extended_WORK(extended_index)+ ADVUGD1E.266
& extended_WORK(extended_index-1)) ADVUGD1E.267
ENDDO ADVUGD1E.268
ENDIF ADVUGD1E.269
ADVUGD1E.270
! Do penultimate point along each row ADVUGD1E.271
ADVUGD1E.272
IF (at_right_of_LPG) THEN ADVUGD1E.273
DO I=START_POINT_NO_HALO+LAST_ROW_PT-2,END_U_POINT_NO_HALO, ADVUGD1E.274
& ROW_LENGTH ADVUGD1E.275
extended_index=extended_address(I) ADVUGD1E.276
ADVUGD1E.277
U_TERM(I)= 0.5*(extended_WORK(extended_index)+ ADVUGD1E.278
& extended_WORK(extended_index-1)) ADVUGD1E.279
ENDDO ADVUGD1E.280
ENDIF ADVUGD1E.281
ADVUGD1E.282
U_TERM(START_POINT_NO_HALO)=0 ADVUGD1E.283
U_TERM(END_U_POINT_NO_HALO)=0 ADVUGD1E.284
ADVUGD1E.285
*ENDIF ADVUGD1E.286
ADVUGD1E.288
CL ADVUGD1E.289
CL--------------------------------------------------------------------- ADVUGD1E.290
CL SECTION 2. CALCULATE V_TERM IN EQUATION (37). ADVUGD1E.291
CL--------------------------------------------------------------------- ADVUGD1E.292
ADVUGD1E.293
C---------------------------------------------------------------------- ADVUGD1E.294
CL SECTION 2.1 CALCULATE TERM V D(FIELD)/D(PHI). ADVUGD1E.295
C---------------------------------------------------------------------- ADVUGD1E.296
ADVUGD1E.297
C CALCULATE TERM AT ALL POINTS EXCEPT LAST AND STORE IN WORK. ADVUGD1E.298
ADVUGD1E.299
! Calculate WORK at the Southern halo too. This is needed for the ADVUGD1E.316
! computation of the Southern row ADVUGD1E.317
ADVUGD1E.318
! DO I=extended_START_POINT_NO_HALO-2*extended_ROW_LENGTH, ADVUGD1E.319
! & extended_END_U_POINT_NO_HALO+extended_ROW_LENGTH ADVUGD1E.320
IF (at_top_of_LPG) THEN ADVUGD1E.321
I_start=extended_address(TOP_ROW_START) ADVUGD1E.322
ELSE ADVUGD1E.323
I_start=extended_START_POINT_NO_HALO-2*extended_ROW_LENGTH ADVUGD1E.324
ENDIF ADVUGD1E.325
IF (at_base_of_LPG) THEN ADVUGD1E.326
I_end=extended_END_U_POINT_NO_HALO-1 ADVUGD1E.327
ELSE ADVUGD1E.328
I_end=extended_END_U_POINT_NO_HALO-1+extended_ROW_LENGTH ADVUGD1E.329
ENDIF ADVUGD1E.330
DO I=I_start,I_end ADVUGD1E.331
extended_WORK(I)=0.5*(V(I,K)+V(I+1,K))*LATITUDE_STEP_INVERSE* ADVUGD1E.332
& (extended_FIELD(I,K)-extended_FIELD(I+extended_ROW_LENGTH,K)) ADVUGD1E.333
ENDDO ADVUGD1E.334
extended_WORK(I_end+1)=extended_WORK(I_end) ADVUGD1E.335
ADVUGD1E.336
ADVUGD1E.339
C---------------------------------------------------------------------- ADVUGD1E.340
CL SECTION 2.2 CALCULATE V ADVECTION TERM IN EQUATION (37). ADVUGD1E.341
CL IF L_SECOND=TRUE ONLY DO SECOND ORDER ADVECTION. ADVUGD1E.342
C---------------------------------------------------------------------- ADVUGD1E.343
ADVUGD1E.344
*IF DEF,GLOBAL ADVUGD1E.375
C GLOBAL MODEL. ADVUGD1E.376
! Calculate all values except on rows next to poles and next to the ADVUGD1E.377
! processor interfaces ADVUGD1E.378
ADVUGD1E.379
! Loop over field, missing top and bottom rows and halos ADVUGD1E.380
IF (at_top_of_LPG) THEN ADVUGD1E.381
I_start=START_POINT_NO_HALO+ROW_LENGTH ADVUGD1E.382
ELSE ADVUGD1E.383
I_start=START_POINT_NO_HALO ADVUGD1E.384
ENDIF ADVUGD1E.385
IF (at_base_of_LPG) THEN ADVUGD1E.386
I_end=END_U_POINT_NO_HALO-ROW_LENGTH ADVUGD1E.387
ELSE ADVUGD1E.388
I_end=END_U_POINT_NO_HALO ADVUGD1E.389
ENDIF ADVUGD1E.390
! DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO ADVUGD1E.391
DO I=I_start,I_end ADVUGD1E.392
extended_index=extended_address(I) ADVUGD1E.393
ADVUGD1E.394
V_TERM(I) = (1.0+NUY(I,K))*0.5* ADVUGD1E.395
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVUGD1E.396
& + extended_WORK(extended_index)) ADVUGD1E.397
& - NUY(I,K) *0.5* ADVUGD1E.398
& (extended_WORK(extended_index+extended_ROW_LENGTH) ADVUGD1E.399
& + extended_WORK(extended_index-2*extended_ROW_LENGTH)) ADVUGD1E.400
ENDDO ADVUGD1E.401
ADVUGD1E.402
C CALCULATE VALUES ON SLICES NEXT TO POLES AND POLAR MERIDIONAL FLUXES. ADVUGD1E.403
C THESE TERMS ARE DIFFERENT TO THE ONES IN LOOP 220 SO AS TO ENSURE ADVUGD1E.404
C CONSERVATION OF FOURTH ORDER SCHEME WITHOUT USING VALUES FROM THE ADVUGD1E.405
C OTHER SIDE OF THE POLE. ADVUGD1E.406
ADVUGD1E.407
IF (at_top_of_LPG) THEN ADVUGD1E.408
! Loop over row beneath pole ADVUGD1E.409
DO I=START_POINT_NO_HALO,START_POINT_NO_HALO+ROW_LENGTH-1 ADVUGD1E.410
extended_index=extended_address(I) ADVUGD1E.411
ADVUGD1E.412
V_TERM(I)=0.5*((1.0+NUY(I,K))* ADVUGD1E.413
& extended_WORK(extended_index-extended_ROW_LENGTH) + ADVUGD1E.414
& extended_WORK(extended_index)) ADVUGD1E.415
& - NUY(I,K)*0.5* ADVUGD1E.416
& extended_WORK(extended_index+extended_ROW_LENGTH) ADVUGD1E.417
ENDDO ADVUGD1E.418
ENDIF ADVUGD1E.419
ADVUGD1E.420
IF (at_base_of_LPG) THEN ADVUGD1E.421
! Loop over row above pole ADVUGD1E.422
DO I=END_U_POINT_NO_HALO-ROW_LENGTH+1,END_U_POINT_NO_HALO ADVUGD1E.423
extended_index=extended_address(I) ADVUGD1E.424
ADVUGD1E.425
V_TERM(I)= ADVUGD1E.426
& 0.5*(extended_WORK(extended_index-extended_ROW_LENGTH) ADVUGD1E.427
& + (1.0+NUY(I,K))*extended_WORK(extended_index)) ADVUGD1E.428
& - NUY(I,K)*0.5* ADVUGD1E.429
& extended_WORK(extended_index-2*extended_ROW_LENGTH) ADVUGD1E.430
ADVUGD1E.431
ENDDO ADVUGD1E.432
ENDIF ADVUGD1E.433
ADVUGD1E.434
*ELSE ADVUGD1E.435
C LIMITED AREA MODEL. ADVUGD1E.436
C CALCULATE ALL VALUES EXCEPT ON ROWS NEXT TO BOUNDARIES. ADVUGD1E.437
ADVUGD1E.438
! Loop over field, missing top and bottom rows and halos ADVUGD1E.439
IF (at_top_of_LPG) THEN ADVUGD1E.440
I_start=START_POINT_NO_HALO+ROW_LENGTH ADVUGD1E.441
ELSE ADVUGD1E.442
I_start=START_POINT_NO_HALO ADVUGD1E.443
ENDIF ADVUGD1E.444
IF (at_base_of_LPG) THEN ADVUGD1E.445
I_end=END_U_POINT_NO_HALO-ROW_LENGTH ADVUGD1E.446
ELSE ADVUGD1E.447
I_end=END_U_POINT_NO_HALO ADVUGD1E.448
ENDIF ADVUGD1E.449
! DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO ADVUGD1E.450
DO I=I_start,I_end ADVUGD1E.451
extended_index=extended_address(I) ADVUGD1E.452
ADVUGD1E.453
V_TERM(I) = (1.0+NUY(I,K))*0.5* ADVUGD1E.454
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVUGD1E.455
& + extended_WORK(extended_index)) ADVUGD1E.456
& - NUY(I,K) *0.5* ADVUGD1E.457
& (extended_WORK(extended_index+extended_ROW_LENGTH) ADVUGD1E.458
& + extended_WORK(extended_index-2*extended_ROW_LENGTH)) ADVUGD1E.459
ENDDO ADVUGD1E.460
ADVUGD1E.461
C CALCULATE VALUES ON SLICES NEXT TO BOUNDARIES AS SECOND ORDER. ADVUGD1E.462
IF (at_top_of_LPG) THEN ADVUGD1E.463
! Loop over row beneath top row ADVUGD1E.464
DO I=START_POINT_NO_HALO+FIRST_ROW_PT-1, ADVUGD1E.465
& START_POINT_NO_HALO+LAST_ROW_PT-1 ADVUGD1E.466
extended_index=extended_address(I) ADVUGD1E.467
V_TERM(I)=0.5* ADVUGD1E.468
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVUGD1E.469
& + extended_WORK(extended_index)) ADVUGD1E.470
ENDDO ADVUGD1E.471
ENDIF ADVUGD1E.472
ADVUGD1E.473
IF (at_base_of_LPG) THEN ADVUGD1E.474
DO I=END_U_POINT_NO_HALO-ROW_LENGTH+FIRST_ROW_PT, ADVUGD1E.475
& END_U_POINT_NO_HALO-ROW_LENGTH+LAST_ROW_PT ADVUGD1E.476
extended_index=extended_address(I) ADVUGD1E.477
V_TERM(I)=0.5* ADVUGD1E.478
& (extended_WORK(extended_index-extended_ROW_LENGTH) ADVUGD1E.479
& + extended_WORK(extended_index)) ADVUGD1E.480
ENDDO ADVUGD1E.481
ENDIF ADVUGD1E.482
ADVUGD1E.483
C CORNER VALUES ADVUGD1E.484
C ADVUGD1E.485
V_TERM(START_POINT_NO_HALO)=0.0 ADVUGD1E.486
V_TERM(START_POINT_NO_HALO+ROW_LENGTH-1)=0.0 ADVUGD1E.487
V_TERM(END_U_POINT_NO_HALO-ROW_LENGTH+1)=0.0 ADVUGD1E.488
V_TERM(END_U_POINT_NO_HALO)=0.0 ADVUGD1E.489
ADVUGD1E.490
*ENDIF ADVUGD1E.491
ADVUGD1E.493
CL ADVUGD1E.494
CL--------------------------------------------------------------------- ADVUGD1E.495
CL SECTION 3. CALCULATE VERTICAL FLUX AND COMBINE WITH U AND V ADVUGD1E.496
CL TERMS TO FORM INCREMENT. ADVUGD1E.497
CL--------------------------------------------------------------------- ADVUGD1E.498
ADVUGD1E.499
CL VERTICAL FLUX ON INPUT IS .5*TIMESTEP*ETADOT*D(FIELD)/D(ETA) ADVUGD1E.500
CL AT LEVEL K-1/2. AT THE END OF THEIS SECTION IT IS THE SAME ADVUGD1E.501
CL QUANTITY BUT AT LEVEL K+1/2. ADVUGD1E.502
ADVUGD1E.503
! Loop over field, missing top and bottom rows and halos ADVUGD1E.504
ADVUGD1E.505
IF(K.NE.1.AND.K.NE.P_LEVELS)THEN ADVUGD1E.506
cdir$ unroll4 ADVUGD1E.507
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 APB3F405.365
SCALAR1 = .5 * ADVECTION_TIMESTEP * ADVUGD1E.509
* ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) ADVUGD1E.510
SCALAR2 = WORK(I) ADVUGD1E.511
WORK(I)=SCALAR1 ADVUGD1E.512
FIELD_INC(I,K) = SCALAR1+SCALAR2 ADVUGD1E.513
IF (LWHITBROM) THEN ADVUGD1E.514
FIELD_INC(I,K) = FIELD_INC(I,K) ADVUGD1E.515
* + FIELD(I,K)*BRSP(I,K) APB3F405.371
END IF ADVUGD1E.517
ENDDO ADVUGD1E.523
ELSE IF(K.EQ.1)THEN ADVUGD1E.524
cdir$ unroll4 ADVUGD1E.525
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 ADVUGD1E.526
SCALAR1 = .5 * ADVECTION_TIMESTEP * ADVUGD1E.527
* ETADOT(I,K+1) * (FIELD(I,K+1) - FIELD(I,K)) ADVUGD1E.528
WORK(I)=SCALAR1 ADVUGD1E.529
FIELD_INC(I,K) = SCALAR1 ADVUGD1E.530
IF (LWHITBROM) THEN ADVUGD1E.531
FIELD_INC(I,K) = FIELD_INC(I,K) ADVUGD1E.532
* + FIELD(I,K)*BRSP(I,K) APB3F405.372
END IF ADVUGD1E.534
ENDDO ADVUGD1E.535
ADVUGD1E.536
ADVUGD1E.542
ELSE IF(K.EQ.P_LEVELS) THEN ADVUGD1E.543
cdir$ unroll4 ADVUGD1E.544
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 ADVUGD1E.545
SCALAR2 = WORK(I) ADVUGD1E.546
FIELD_INC(I,K) = SCALAR2 ADVUGD1E.547
IF (LWHITBROM) THEN ADVUGD1E.548
FIELD_INC(I,K) = FIELD_INC(I,K) ADVUGD1E.549
* + FIELD(I,K)*BRSP(I,K) APB3F405.373
END IF ADVUGD1E.551
ENDDO ADVUGD1E.552
APB3F405.366
ENDIF !IF(K.EQ.P_LEVELS) APB3F405.367
APB3F405.368
cdir$ unroll4 ADVUGD1E.553
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 ADVUGD1E.554
FIELD_INC(I,K) = ADVECTION_TIMESTEP * SEC_U_LATITUDE(I) * ADVUGD1E.555
* (U_TERM(I)+V_TERM(I)) + FIELD_INC(I,K) ADVUGD1E.556
ENDDO ADVUGD1E.557
ADVUGD1E.559
FIELD_INC(END_U_POINT_NO_HALO,K)=0.0 ADVUGD1E.560
ADVUGD1E.561
*IF -DEF,GLOBAL ADVUGD1E.562
ADVUGD1E.563
CL LIMITED AREA MODEL SET BOUNDARY INCREMENTS TO ZERO. ADVUGD1E.564
ADVUGD1E.565
IF (at_left_of_LPG) THEN ADVUGD1E.566
DO I=START_POINT_NO_HALO+FIRST_ROW_PT-1, ADVUGD1E.567
& END_U_POINT_NO_HALO,ROW_LENGTH ADVUGD1E.568
FIELD_INC(I,K)=0.0 ADVUGD1E.569
ENDDO ADVUGD1E.570
ENDIF ADVUGD1E.571
ADVUGD1E.572
IF (at_right_of_LPG) THEN ADVUGD1E.573
DO I=START_POINT_NO_HALO+LAST_ROW_PT-2, ADVUGD1E.574
& END_U_POINT_NO_HALO,ROW_LENGTH ADVUGD1E.575
FIELD_INC(I,K)=0.0 ADVUGD1E.576
FIELD_INC(I+1,K)=0.0 ADVUGD1E.577
ENDDO ADVUGD1E.578
ENDIF ADVUGD1E.579
ADVUGD1E.580
*ENDIF ADVUGD1E.581
ADVUGD1E.582
ENDDO !DO K=1,P_LEVELS ADVUGD1E.583
APB3F405.369
ENDIF !IF(L_SECOND) APB3F405.370
ADVUGD1E.584
CL END OF ROUTINE ADV_U_GD ADVUGD1E.585
ADVUGD1E.586
RETURN ADVUGD1E.587
END ADVUGD1E.588
*ENDIF ADVUGD1E.589
*ENDIF ADVUGD1E.590