*IF DEF,A12_1C,OR,DEF,A12_1D ATJ0F402.14
*IF DEF,MPP ATJ0F402.15
C *****************************COPYRIGHT****************************** UVADV1C.3
C (c) CROWN COPYRIGHT 1996, METEOROLOGICAL OFFICE, All Rights Reserved. UVADV1C.4
C UVADV1C.5
C Use, duplication or disclosure of this code is subject to the UVADV1C.6
C restrictions as set forth in the contract. UVADV1C.7
C UVADV1C.8
C Meteorological Office UVADV1C.9
C London Road UVADV1C.10
C BRACKNELL UVADV1C.11
C Berkshire UK UVADV1C.12
C RG12 2SZ UVADV1C.13
C UVADV1C.14
C If no contract has been raised with this copy of the code, the use, UVADV1C.15
C duplication or disclosure of it is strictly prohibited. Permission UVADV1C.16
C to do so must first be obtained in writing from the Head of Numerical UVADV1C.17
C Modelling at the above address. UVADV1C.18
C ******************************COPYRIGHT****************************** UVADV1C.19
CLL SUBROUTINE UV_ADV ------------------------------------------- UVADV1C.20
CLL UVADV1C.21
CLL PURPOSE: UVADV1C.22
CLL CALCULATES MASS-WEIGHTED INCREMENTS TO U AND V DUE TO UVADV1C.23
CLL ADVECTION BY USING EQUATIONS (37) AND (38) TO CALCULATE UVADV1C.24
CLL PROVISIONAL VALUES OF U AND V AT THE NEW TIME-LEVEL, AND THEN UVADV1C.25
CLL RECALCULATING THE ADVECTION TERMS ON THE RIGHT-HAND SIDE OF (41) UVADV1C.26
CLL AND (42) USING THESE PROVISIONAL VALUES. THE CORIOLIS TERMS UVADV1C.27
CLL ASSOCIATED WITH THE VERTICAL VELOCITY ARE CALCULATED AND INCLUDED UVADV1C.28
CLL IN THE INCREMENTS. THE FINAL INCREMENTS ARE CALCULATED AS IN UVADV1C.29
CLL EQUATIONS (41) AND (42). IF RUNNING A GLOBAL MODEL POLAR_UV IS UVADV1C.30
CLL CALLED TO UPDATE POLAR VALUES. UVADV1C.31
CLL UVADV1C.32
CLL CHANGES INCLUDE:- UVADV1C.33
CLL U_MEAN AND V_MEAN FIELDS NOT OVER-WRITTEN WHEN INTERPOLATION TO UVADV1C.34
CLL U_GRID PERFORMED. ETADOT AND RS FIELDS INTERPOLATED TO U_GRID INSIDE UVADV1C.35
CLL THIS ROUTINE INSTEAD OF INSIDE ADV_CTL. THIS COSTS 8 EXTRA UVADV1C.36
CLL HORIZONTAL FIELDS BUT ALLOWS ROUTINE TO BE CALLED BEFORE TH_ADV SO UVADV1C.37
CLL THAT OMEGA CALCULATED HERE CAN BE USED INSIDE TH_ADV TO CALCULATE UVADV1C.38
CLL EXTRA THERMODYNAMIC TERM. UVADV1C.39
CLL UVADV1C.40
CLL INCLUSION OF L_SECOND TO CHOOSE CHEAPER SECOND ORDER ADVECTION UVADV1C.41
CLL SCHEME ALONG WITH REMOVAL OF CODE PREVIOUSLY UNDER *DEF FORECAST. UVADV1C.42
CLL CODE INCLUDED TO ALLOW HALF-TIMESTEP TO BE USED AT TOP LEVEL. UVADV1C.43
CLL UVADV1C.44
CLL NOT SUITABLE FOR SINGLE COLUMN USE. UVADV1C.45
CLL VERSION FOR CRAY Y-MP UVADV1C.46
CLL UVADV1C.47
CLL WRITTEN M.H MAWSON. UVADV1C.48
CLL MPP CODE ADDED BY P.BURTON UVADV1C.49
CLL UVADV1C.50
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 4.1: UVADV1C.51
CLL VERSION DATE UVADV1C.52
CLL 4.1 08/12/95 New version of routine specifically for MPP UVADV1C.53
CLL P.Burton UVADV1C.54
!LL 4.2 10/01/97 Initialise unprocessed points in U_PROV ADR2F402.22
!LL and V_PROV. D. Robinson. ADR2F402.23
!LL 4.3 24/04/97 Fixes to 4th order calculations P.Burton GPB5F403.33
C vn4.3 Mar. 97 T3E migration : optimisation changes GSS1F403.722
C D.Salmond GSS1F403.723
UVADV1C.55
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, UVADV1C.56
CLL STANDARD B. UVADV1C.57
CLL UVADV1C.58
CLL SYSTEM COMPONENTS COVERED: P122 UVADV1C.59
CLL UVADV1C.60
CLL SYSTEM TASK: P1 UVADV1C.61
CLL UVADV1C.62
CLL DOCUMENTATION: THE EQUATIONS USED ARE (37-38) AND (41-42) UVADV1C.63
CLL IN UNIFIED MODEL DOCUMENTATION PAPER NO. 10 UVADV1C.64
CLL M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON UVADV1C.65
CLL UVADV1C.66
CLLEND------------------------------------------------------------- UVADV1C.67
UVADV1C.68
C*L ARGUMENTS:--------------------------------------------------- UVADV1C.69
SUBROUTINE UV_ADV 2,59UVADV1C.70
& (U,V,PSTAR_OLD,PSTAR,U_MEAN,V_MEAN,SEC_U_LATITUDE, UVADV1C.71
& ETADOT_MEAN,RS,DELTA_AK,DELTA_BK,AK,BK,F1,F2, UVADV1C.72
& LATITUDE_STEP_INVERSE,ADVECTION_TIMESTEP,NU_BASIC, UVADV1C.73
& LONGITUDE_STEP_INVERSE,U_FIELD,P_FIELD, UVADV1C.74
& ROW_LENGTH,P_LEVELS, UVADV1C.75
*CALL ARGFLDPT 
UVADV1C.76
& COS_U_LONGITUDE,SIN_U_LONGITUDE,SEC_P_LATITUDE, UVADV1C.77
& AKH,BKH,OMEGA,L_SECOND,LLINTS, UVADV1C.78
& extended_address, GSS1F403.724
& LWHITBROM,X_FIELD) UVADV1C.79
UVADV1C.80
IMPLICIT NONE UVADV1C.81
UVADV1C.82
INTEGER UVADV1C.83
& P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. UVADV1C.84
&, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID UVADV1C.85
&, X_FIELD !IN 1 IF 2ND ORDER ELSE U_FIELD UVADV1C.86
&, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. UVADV1C.87
&, ROW_LENGTH !IN NUMBER OF POINTS PER ROW UVADV1C.88
UVADV1C.89
! All TYPFLDPT arguments are intent IN UVADV1C.90
*CALL TYPFLDPT UVADV1C.91
UVADV1C.92
C LOGICAL VARIABLE UVADV1C.93
LOGICAL UVADV1C.94
& L_SECOND ! SET TO TRUE IF NU_BASIC IS ZERO. UVADV1C.95
& ,LLINTS ! Switch for linear TS calc in CALC_TS UVADV1C.96
& ,LWHITBROM ! Switch for White & Bromley terms UVADV1C.97
INTEGER extended_address(P_FIELD) GSS1F403.725
UVADV1C.98
REAL UVADV1C.99
& U_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED U VELOCITY UVADV1C.100
& ! FROM ADJUSTMENT STEP HELD AT U UVADV1C.101
& ! POINTS. UVADV1C.102
&,V_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED V VELOCITY UVADV1C.103
& ! * COS(LAT) FROM ADJUSTMENT STEP UVADV1C.104
&,ETADOT_MEAN(P_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED UVADV1C.105
& !VERTICAL VELOCITY FROM ADJUSTMENT STEP UVADV1C.106
UVADV1C.107
REAL UVADV1C.108
& U(U_FIELD,P_LEVELS) !INOUT IN U FIELD, UVADV1C.109
& ! OUT MASS-WEIGHTED U FIELD. UVADV1C.110
&,V(U_FIELD,P_LEVELS) !INOUT IN V FIELD, UVADV1C.111
& ! OUT MASS-WEIGHTED V FIELD. UVADV1C.112
UVADV1C.113
REAL UVADV1C.114
& PSTAR(U_FIELD) !IN PSTAR FIELD AT NEW TIME-LEVEL ON UVADV1C.115
& ! U GRID. UVADV1C.116
&,PSTAR_OLD(U_FIELD) !IN PSTAR AT PREVIOUS TIME-LEVEL ON UVADV1C.117
& ! U GRID. UVADV1C.118
&,RS(P_FIELD,P_LEVELS) !IN RS FIELD. UVADV1C.119
&,AK(P_LEVELS) !IN FIRST TERM IN HYBRID CO-ORDS. UVADV1C.120
&,BK(P_LEVELS) !IN SECOND TERM IN HYBRID CO-ORDS. UVADV1C.121
&,DELTA_AK(P_LEVELS) !IN LAYER THICKNESS UVADV1C.122
&,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS UVADV1C.123
&,AKH(P_LEVELS+1) !IN HYBRID CO-ORDINATE AT HALF LEVELS UVADV1C.124
&,BKH(P_LEVELS+1) !IN HYBRID CO-ORDINATE AT HALF LEVELS UVADV1C.125
&,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) UVADV1C.126
&,SEC_P_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT P POINTS (2-D ARRAY) UVADV1C.127
&,SIN_U_LONGITUDE(ROW_LENGTH) !IN SIN(LONGITUDE) AT U POINTS. UVADV1C.128
&,COS_U_LONGITUDE(ROW_LENGTH) !IN COS(LONGITUDE) AT U POINTS. UVADV1C.129
UVADV1C.130
REAL UVADV1C.131
& LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) UVADV1C.132
&,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) UVADV1C.133
&,ADVECTION_TIMESTEP !IN UVADV1C.134
&,NU_BASIC !IN STANDARD NU TERM FOR MODEL RUN. UVADV1C.135
&,F1(U_FIELD) !IN A CORIOLIS TERM (SEE DOCUMENTATION) UVADV1C.136
&,F2(U_FIELD) !IN A CORIOLIS TERM (SEE DOCUMENTATION) UVADV1C.137
UVADV1C.138
REAL UVADV1C.139
& OMEGA(U_FIELD,P_LEVELS) !OUT TRUE VERTICAL VELOCITY UVADV1C.140
UVADV1C.141
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- UVADV1C.142
C DEFINE LOCAL ARRAYS: 35 ARE REQUIRED UVADV1C.143
REAL UVADV1C.144
& RS_U(U_FIELD,P_LEVELS) ! RS AT U POINTS FOR CURRENT LEVE UVADV1C.145
&,ETADOT_U(U_FIELD,P_LEVELS+1) ! ETADOT AT U POINTS FOR CURRENT LE UVADV1C.146
&,U_MEAN_P(U_FIELD,P_LEVELS) ! U MEAN AT P POINTS FOR CURRENT LEVEL UVADV1C.147
& ! WITH FIRST POINT OF FIELD NOW UVADV1C.148
& ! BEING FIRST P POINT ON SECOND ROW UVADV1C.149
& ! OF P-GRID. UVADV1C.150
&,V_MEAN_P(U_FIELD,P_LEVELS) ! V MEAN AT P POINTS FOR CURRENT LEVEL UVADV1C.151
& ! WITH FIRST POINT OF FIELD NOW UVADV1C.152
& ! BEING FIRST P POINT ON SECOND ROW UVADV1C.153
& ! OF P-GRID. UVADV1C.154
UVADV1C.155
REAL UVADV1C.156
& U_FIRST_INC(U_FIELD) ! HOLDS U INCREMENT UVADV1C.157
& !RETURNED BY FIRST CALL TO ADV_U_GD UVADV1C.158
&,U_SECOND_INC(U_FIELD) ! HOLDS U INCREMENT UVADV1C.159
& !RETURNED BY SECOND CALL TO ADV_U_GD UVADV1C.160
&,U_PROV(U_FIELD,P_LEVELS) ! HOLDS PROVISIONAL VALUE OF UVADV1C.161
UVADV1C.162
REAL UVADV1C.163
& V_FIRST_INC(U_FIELD) ! HOLDS V INCREMENT UVADV1C.164
& !RETURNED BY FIRST CALL TO ADV_U_GD UVADV1C.165
&,V_SECOND_INC(U_FIELD) ! HOLDS V INCREMENT UVADV1C.166
& !RETURNED BY SECOND CALL TO ADV_U_GD UVADV1C.167
&,V_PROV(U_FIELD,P_LEVELS) ! HOLDS PROVISIONAL VALUE OF UVADV1C.168
UVADV1C.169
C NP DENOTES NORTH POLE, SP DENOTES SOUTH POLE. UVADV1C.170
C POLAR INCREMENT ARRAYS ARE NOT USED IN LIMITED AREA MODEL BUT TO UVADV1C.171
C REMOVE THEM WOULD LEAD TO MODIFYING THE NUMBER OF VARIABLES UVADV1C.172
C PASSED TO ADV_U_GD. THE RETENTION OF THESE ARRAYS ADDS ONLY UVADV1C.173
C 12*ROW_LENGTH TO THE SPACE USED AND NOTHING TO THE CALCULATION UVADV1C.174
C TIME AS ALL USES OF THEM IN CALCULATION ARE CONTROLLED BY *IF'S. UVADV1C.175
UVADV1C.176
REAL UVADV1C.177
& NUX(X_FIELD,P_LEVELS) ! COURANT NUMBER DEPENDENT NU AT U POI UVADV1C.178
& ! USED IN EAST-WEST ADVECTION. UVADV1C.179
&,NUY(X_FIELD,P_LEVELS) ! COURANT NUMBER DEPENDENT NU AT U POI UVADV1C.180
& ! USED IN NORTH-SOUTH ADVECTION. UVADV1C.181
UVADV1C.182
REAL NUX_MIN(upd_P_ROWS), ! minimum value of NUX along a row UVADV1C.183
& NUY_MIN(ROW_LENGTH) ! min of NUY along a column UVADV1C.184
UVADV1C.185
REAL UVADV1C.186
& DELTA_AKH(P_LEVELS+1) ! LAYER THICKNESS AK(K) - AK(K-1) UVADV1C.187
&,DELTA_BKH(P_LEVELS+1) ! LAYER THICKNESS BK(K) - BK(K-1) UVADV1C.188
&,WK(U_FIELD) ! WK AS IN EQUATION (46). UVADV1C.189
UVADV1C.190
! Work space required to allow the use of Fourth Order Advection UVADV1C.191
! U/V_MEAN_P_COPY and U/V_COPY arrays are defined with an extra halo UVADV1C.192
! this is required for the bigger stencil of the 4th order operator. UVADV1C.193
UVADV1C.194
REAL U_MEAN_P_COPY((ROW_LENGTH+2*extra_EW_Halo)* UVADV1C.195
& (tot_U_ROWS+2*extra_NS_Halo),P_LEVELS), UVADV1C.196
& ! Copy of U_MEAN with extra halo space for 4th order UVADV1C.197
& V_MEAN_P_COPY((ROW_LENGTH+2*extra_EW_Halo)* UVADV1C.198
& (tot_U_ROWS+2*extra_NS_Halo),P_LEVELS), UVADV1C.199
& ! Copy of V_MEAN with extra halo space for 4th order UVADV1C.200
& U_COPY((ROW_LENGTH+2*extra_EW_Halo)* UVADV1C.201
& (tot_U_ROWS+2*extra_NS_Halo),P_LEVELS), UVADV1C.202
& ! Copy of U with extra halo space for 4th order UVADV1C.203
& V_COPY((ROW_LENGTH+2*extra_EW_Halo)* UVADV1C.204
& (tot_U_ROWS+2*extra_NS_Halo),P_LEVELS) UVADV1C.205
& ! Copy of V with extra halo space for 4th order UVADV1C.206
UVADV1C.207
INTEGER extended_P_FIELD, UVADV1C.208
& extended_U_FIELD UVADV1C.209
! These are the sizes of the arrays with the extra halos UVADV1C.210
UVADV1C.211
C*--------------------------------------------------------------------- UVADV1C.212
C DEFINE LOCAL VARIABLES UVADV1C.213
INTEGER UVADV1C.214
& U_POINTS_UPDATE ! NUMBER OF U POINTS TO BE UPDATED. UVADV1C.215
& ! = (ROWS-1)*ROWLENGTH UVADV1C.216
UVADV1C.217
C REAL SCALARS UVADV1C.218
REAL UVADV1C.219
& SCALAR1,SCALAR2,SCALAR3,SCALAR4,TIMESTEP UVADV1C.220
UVADV1C.221
C COUNT VARIABLES FOR DO LOOPS ETC. UVADV1C.222
INTEGER UVADV1C.223
& I,J,KP,KM,IK,K,IL UVADV1C.224
INTEGER I_start,I_end UVADV1C.225
INTEGER info ! return code from comms UVADV1C.226
UVADV1C.227
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- UVADV1C.228
EXTERNAL ADV_U_GD,POLAR_UV,V_CORIOL,UV_TO_P,P_TO_UV UVADV1C.229
*IF DEF,CRAY UVADV1C.230
INTEGER ISMIN UVADV1C.231
EXTERNAL ISMIN UVADV1C.232
*ENDIF UVADV1C.233
C*--------------------------------------------------------------------- UVADV1C.234
UVADV1C.235
CL MAXIMUM VECTOR LENGTH ASSUMED IS (ROWS+1) * ROWLENGTH UVADV1C.236
CL--------------------------------------------------------------------- UVADV1C.237
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: UVADV1C.238
CL--------------------------------------------------------------------- UVADV1C.239
CL UVADV1C.240
CL--------------------------------------------------------------------- UVADV1C.241
CL SECTION 1. INITIALISATION UVADV1C.242
CL--------------------------------------------------------------------- UVADV1C.243
C INCLUDE LOCAL CONSTANTS FROM GENERAL CONSTANTS BLOCK UVADV1C.244
UVADV1C.245
U_POINTS_UPDATE = upd_U_ROWS*ROW_LENGTH UVADV1C.246
UVADV1C.247
!QAN fix for RS_U UVADV1C.248
DO K=1,P_LEVELS UVADV1C.249
DO I=1,U_FIELD UVADV1C.250
RS_U(I,K)=0.0 UVADV1C.251
ENDDO UVADV1C.252
ENDDO UVADV1C.253
UVADV1C.254
DO K=1,P_LEVELS UVADV1C.255
CL INTERPOLATE RS ONTO U GRID. UVADV1C.256
! CALL P_TO_UV(RS(1,K),RS_U(1,K),P_FIELD,U_FIELD,ROW_LENGTH, UVADV1C.257
! & tot_P_ROWS) UVADV1C.258
CALL P_TO_UV(RS(FIRST_VALID_PT,K),RS_U(FIRST_VALID_PT,K), UVADV1C.259
& P_FIELD-FIRST_VALID_PT+1,U_FIELD-FIRST_VALID_PT+1, UVADV1C.260
& ROW_LENGTH,VALID_P_ROWS) UVADV1C.261
ENDDO UVADV1C.262
UVADV1C.263
CL INTERPOLATE ETADOT ONTO U GRID AND INCLUDE BOTTOM AND TOP UVADV1C.264
CL BOUNDARY CONDITION UVADV1C.265
UVADV1C.266
DO K =2, P_LEVELS UVADV1C.267
! CALL P_TO_UV(ETADOT_MEAN(1,K),ETADOT_U(1,K),P_FIELD,U_FIELD, UVADV1C.268
! & ROW_LENGTH,tot_P_ROWS) UVADV1C.269
CALL P_TO_UV(ETADOT_MEAN(FIRST_VALID_PT,K), UVADV1C.270
& ETADOT_U(FIRST_VALID_PT,K), UVADV1C.271
& P_FIELD-FIRST_VALID_PT+1,U_FIELD-FIRST_VALID_PT+1, UVADV1C.272
& ROW_LENGTH,VALID_P_ROWS) UVADV1C.273
END DO UVADV1C.274
DO I = FIRST_VALID_PT,LAST_U_VALID_PT UVADV1C.275
ETADOT_U(I,1) = 0.0 UVADV1C.276
ETADOT_U(I,P_LEVELS+1) = 0.0 UVADV1C.277
END DO UVADV1C.278
UVADV1C.279
IF (LWHITBROM) THEN UVADV1C.280
UVADV1C.281
! CALL FILL_HALOS(RS_U,U_FIELD,ROW_LENGTH,P_LEVELS,fld_type_u) UVADV1C.282
UVADV1C.283
CL CALCULATE BRSP TERM AT LEVEL K UVADV1C.284
C STORE IN OMEGA TO SAVE WORKSPACE UVADV1C.285
UVADV1C.286
K=1 UVADV1C.287
DO I=FIRST_VALID_PT,LAST_U_VALID_PT UVADV1C.288
OMEGA(I,K)=(3.*RS_U(I,K)+RS_U(I,K+1))*(RS_U(I,K)-RS_U(I,K+1)) UVADV1C.289
& *BKH(K+1)*.25*(PSTAR(I)-PSTAR_OLD(I)) UVADV1C.290
ENDDO UVADV1C.291
K=P_LEVELS UVADV1C.292
DO I=FIRST_VALID_PT,LAST_U_VALID_PT UVADV1C.293
OMEGA(I,K)=-(3.*RS_U(I,K)+RS_U(I,K-1))*(RS_U(I,K)-RS_U(I,K-1)) UVADV1C.294
& *BKH(K)*.25*(PSTAR(I)-PSTAR_OLD(I)) UVADV1C.295
ENDDO UVADV1C.296
UVADV1C.297
DO K=2,P_LEVELS -1 UVADV1C.298
DO I=FIRST_VALID_PT,LAST_U_VALID_PT UVADV1C.299
OMEGA(I,K)=((3.*RS_U(I,K)+RS_U(I,K+1)) UVADV1C.300
& *(RS_U(I,K)-RS_U(I,K+1))*BKH(K+1) UVADV1C.301
& *.25*(PSTAR(I)-PSTAR_OLD(I))) UVADV1C.302
& -((3.*RS_U(I,K)+RS_U(I,K-1)) UVADV1C.303
& *(RS_U(I,K)-RS_U(I,K-1))*BKH(K) UVADV1C.304
& *.25*(PSTAR(I)-PSTAR_OLD(I))) UVADV1C.305
ENDDO UVADV1C.306
UVADV1C.307
ENDDO UVADV1C.308
ENDIF UVADV1C.309
UVADV1C.310
! Precalculate U_MEAN and V_MEAN interpolated onto P grid - since it UVADV1C.311
! requires a call to SWAPBOUNDS, if we do it outside the main loop UVADV1C.312
! over levels, we can do just one call rather than a seperate call UVADV1C.313
! for each level (inefficient) UVADV1C.314
UVADV1C.315
DO K=1,P_LEVELS UVADV1C.316
! QAN fix APB1F402.55
DO I=1,U_FIELD APB1F402.56
U_MEAN_P(I,K)=0.0 APB1F402.57
V_MEAN_P(I,K)=0.0 APB1F402.58
ENDDO APB1F402.59
CALL UV_TO_P(U_MEAN(FIRST_VALID_PT,K), UVADV1C.317
& U_MEAN_P(FIRST_VALID_PT,K), UVADV1C.318
& U_FIELD-FIRST_VALID_PT+1, UVADV1C.319
& U_FIELD-FIRST_VALID_PT+1, UVADV1C.320
& ROW_LENGTH,upd_U_ROWS+2) UVADV1C.321
! & ROW_LENGTH,upd_P_ROWS+1) UVADV1C.322
! CALL UV_TO_P(U_MEAN(1,K),U_MEAN_P(1,K),U_FIELD,U_FIELD, UVADV1C.323
! & ROW_LENGTH, tot_P_ROWS) UVADV1C.324
UVADV1C.325
CALL UV_TO_P(V_MEAN(FIRST_VALID_PT,K), UVADV1C.326
& V_MEAN_P(FIRST_VALID_PT,K), UVADV1C.327
& U_FIELD-FIRST_VALID_PT+1, UVADV1C.328
& U_FIELD-FIRST_VALID_PT+1, UVADV1C.329
& ROW_LENGTH,upd_U_ROWS+2) UVADV1C.330
! & ROW_LENGTH,upd_P_ROWS+1) UVADV1C.331
! CALL UV_TO_P(V_MEAN(1,K),V_MEAN_P(1,K),U_FIELD,U_FIELD, UVADV1C.332
! & ROW_LENGTH, tot_P_ROWS) UVADV1C.333
ENDDO UVADV1C.334
UVADV1C.335
! This seems to be what was in the code originally but I can't UVADV1C.336
! understand. There seems no need since U_MEAN and V_MEAN are swapped UVADV1C.337
! in ADJ_CTL. But I would have thought the _P versions would need UVADV1C.338
! to be swapped as they are used in the advection routine. But there UVADV1C.339
! is no sign of a swap in the original code. Some experiment is UVADV1C.340
! required methinks! UVADV1C.341
UVADV1C.342
! CALL SWAPBOUNDS(U_MEAN,ROW_LENGTH,lasize(2),Offx,Offy,P_LEVELS) UVADV1C.343
! CALL SWAPBOUNDS(V_MEAN,ROW_LENGTH,lasize(2),Offx,Offy,P_LEVELS) UVADV1C.344
UVADV1C.345
CFPP$ NOCONCUR UVADV1C.346
DO I=2,P_LEVELS UVADV1C.347
DELTA_AKH(I) = AK(I) - AK(I-1) UVADV1C.348
DELTA_BKH(I) = BK(I) - BK(I-1) UVADV1C.349
ENDDO UVADV1C.350
C THESE ZERO VALUES SAVE HAVING TO PASS THE ZERO VERTICAL VELOCITIES UVADV1C.351
C ON LOWER AND UPPER BOUNDARIES TO V_CORIOL AS THE ZERO VELOCITIES ARE UVADV1C.352
C NOT HELD. (SEE CALL TO V_CORIOL IN SECTION 3.3) UVADV1C.353
DELTA_AKH(1) = 0.0 UVADV1C.354
DELTA_BKH(1) = 0.0 UVADV1C.355
DELTA_AKH(P_LEVELS+1) = 0.0 UVADV1C.356
DELTA_BKH(P_LEVELS+1) = 0.0 UVADV1C.357
UVADV1C.358
! In order to use the same call to adv_u_gd for both the second and UVADV1C.359
! fourth order advection, U/V_MEAN_P are copied into _COPY arrays. UVADV1C.360
! In the case of second order advection some of the work space is UVADV1C.361
! wasted as there is more halo than we need. UVADV1C.362
UVADV1C.363
! Calculate the size of the extended arrays which contain an UVADV1C.364
! extra halo: UVADV1C.365
extended_U_FIELD=(ROW_LENGTH+2*extra_EW_Halo)* UVADV1C.366
& (tot_U_ROWS+2*extra_NS_Halo) UVADV1C.367
extended_P_FIELD=(ROW_LENGTH+2*extra_EW_Halo)* UVADV1C.368
& (tot_P_ROWS+2*extra_NS_Halo) UVADV1C.369
UVADV1C.370
IF (L_SECOND) THEN UVADV1C.371
UVADV1C.372
! Copy U/V_MEAN to U/V_MEAN_COPY with the same sized halos UVADV1C.373
CALL COPY_FIELD(U_MEAN_P,U_MEAN_P_COPY, UVADV1C.374
& U_FIELD,extended_U_FIELD, UVADV1C.375
& ROW_LENGTH,tot_U_ROWS,P_LEVELS, UVADV1C.376
& EW_Halo,NS_Halo, UVADV1C.377
& EW_Halo,NS_Halo, UVADV1C.378
& .FALSE.) UVADV1C.379
CALL COPY_FIELD(V_MEAN_P,V_MEAN_P_COPY, UVADV1C.380
& U_FIELD,extended_U_FIELD, UVADV1C.381
& ROW_LENGTH,tot_U_ROWS,P_LEVELS, UVADV1C.382
& EW_Halo,NS_Halo, UVADV1C.383
& EW_Halo,NS_Halo, UVADV1C.384
& .FALSE.) UVADV1C.385
UVADV1C.386
ELSE ! if its fourth order: UVADV1C.387
UVADV1C.388
CALL COPY_FIELD(U_MEAN_P,U_MEAN_P_COPY, UVADV1C.389
& U_FIELD,extended_U_FIELD, UVADV1C.390
& ROW_LENGTH,tot_U_ROWS,P_LEVELS, UVADV1C.391
& EW_Halo,NS_Halo, UVADV1C.392
& halo_4th,halo_4th, UVADV1C.393
& .TRUE.) UVADV1C.394
CALL COPY_FIELD(V_MEAN_P,V_MEAN_P_COPY, UVADV1C.395
& U_FIELD,extended_U_FIELD, UVADV1C.396
& ROW_LENGTH,tot_U_ROWS,P_LEVELS, UVADV1C.397
& EW_Halo,NS_Halo, UVADV1C.398
& halo_4th,halo_4th, UVADV1C.399
& .TRUE.) UVADV1C.400
CALL COPY_FIELD(U,U_COPY, UVADV1C.401
& U_FIELD,extended_U_FIELD, UVADV1C.402
& ROW_LENGTH,tot_U_ROWS,P_LEVELS, UVADV1C.403
& EW_Halo,NS_Halo, UVADV1C.404
& halo_4th,halo_4th, UVADV1C.405
& .TRUE.) UVADV1C.406
CALL COPY_FIELD(V,V_COPY, UVADV1C.407
& U_FIELD,extended_U_FIELD, UVADV1C.408
& ROW_LENGTH,tot_U_ROWS,P_LEVELS, UVADV1C.409
& EW_Halo,NS_Halo, UVADV1C.410
& halo_4th,halo_4th, UVADV1C.411
& .TRUE.) UVADV1C.412
UVADV1C.413
ENDIF ! IF (L_SECOND) UVADV1C.414
UVADV1C.415
CL--------------------------------------------------------------------- UVADV1C.416
CL SECTION 2. ADVECTION OF U AND V. UVADV1C.417
CL SECTION 2 WILL CALCULATE PROVISIONAL VALUES OF UVADV1C.418
CL U AND V. SECTION 3 WILL CALCULATE FINAL VALUES. UVADV1C.419
CL--------------------------------------------------------------------- UVADV1C.420
UVADV1C.421
CL LOOP OVER P_LEVELS. UVADV1C.422
UVADV1C.423
DO K=1,P_LEVELS UVADV1C.424
CL SET TIMESTEP APPROPRIATE TO LEVEL UVADV1C.425
UVADV1C.426
TIMESTEP = ADVECTION_TIMESTEP UVADV1C.427
UVADV1C.428
C --------------------------------------------------------------------- UVADV1C.429
CL SECTION 2.1 SET NU DEPENDENT ON NU_BASIC AND MAX COURANT UVADV1C.430
CL NUMBER. UVADV1C.431
C --------------------------------------------------------------------- UVADV1C.432
CL IF NU_BASIC NOT EQUAL TO ZERO. UVADV1C.433
IF(.NOT.L_SECOND) THEN UVADV1C.434
CL THEN SET NU DEPENDENT ON NU_BASIC AND MAX UVADV1C.435
CL COURANT NUMBER. UVADV1C.436
CL CALCULATE COURANT NUMBER SQUARED. UVADV1C.437
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO UVADV1C.438
SCALAR1 = U_MEAN_P(I,K)*LONGITUDE_STEP_INVERSE UVADV1C.439
SCALAR2 = V_MEAN_P(I,K)*LATITUDE_STEP_INVERSE UVADV1C.440
SCALAR3 = TIMESTEP/ UVADV1C.441
& (RS_U(I,K)*RS_U(I,K)*(DELTA_AK(K)+DELTA_BK(K)* UVADV1C.442
& PSTAR_OLD(I))) UVADV1C.443
SCALAR4 = SEC_U_LATITUDE(I)*SCALAR3 UVADV1C.444
SCALAR1 = SCALAR1*SCALAR1 UVADV1C.445
SCALAR2 = SCALAR2*SCALAR2 UVADV1C.446
SCALAR3 = SCALAR3*SCALAR3 UVADV1C.447
SCALAR4 = SCALAR4*SCALAR4 UVADV1C.448
CL CALCULATE NU PARAMETER. UVADV1C.449
UVADV1C.450
NUX(I,K) = (1.- SCALAR4*SCALAR1)*NU_BASIC UVADV1C.451
NUY(I,K) = (1.- SCALAR3*SCALAR2)*NU_BASIC UVADV1C.452
ENDDO UVADV1C.453
UVADV1C.454
! Set NUX equal to minimum value along each row UVADV1C.455
UVADV1C.456
UVADV1C.457
DO J=FIRST_ROW,FIRST_ROW+upd_U_ROWS-1 UVADV1C.458
I_start=(J-1)*ROW_LENGTH+FIRST_ROW_PT ! start and end of row UVADV1C.459
I_end=(J-1)*ROW_LENGTH+LAST_ROW_PT ! missing out halos UVADV1C.460
! Calculate minimum along this row UVADV1C.461
*IF DEF,CRAY UVADV1C.462
IK=ISMIN(I_end-I_start+1,NUX(I_start,K),1) UVADV1C.463
SCALAR1=NUX(IK+I_start-1,K) UVADV1C.464
*ELSE UVADV1C.465
SCALAR1=NUX(I_start,K) UVADV1C.466
DO I=I_start+1,I_end UVADV1C.467
IF (NUX(I,K) .LT. SCALAR1) SCALAR1=NUX(I,K) UVADV1C.468
ENDDO UVADV1C.469
*ENDIF UVADV1C.470
NUX_MIN(J-FIRST_ROW+1)=SCALAR1 UVADV1C.471
! The indexing of NUX_MIN goes from 1..ROWS UVADV1C.472
ENDDO ! J : loop over rows UVADV1C.473
UVADV1C.474
! So far we have only calculated the minimum along our local UVADV1C.475
! part of the row. Now we must find the minimum of all the UVADV1C.476
! local minimums along the row UVADV1C.477
CALL GCG_RMIN(upd_U_ROWS,GC_ROW_GROUP,info,NUX_MIN) UVADV1C.478
UVADV1C.479
! and now set all values of NUX to the minimum along the row UVADV1C.480
DO J=FIRST_ROW,FIRST_ROW+upd_U_ROWS-1 UVADV1C.481
IF (NUX_MIN(J-FIRST_ROW+1) .LT. 0.0) UVADV1C.482
& NUX_MIN(J-FIRST_ROW+1)=0.0 UVADV1C.483
UVADV1C.484
I_start=(J-1)*ROW_LENGTH+1 ! beginning and UVADV1C.485
I_end=J*ROW_LENGTH ! end of row UVADV1C.486
UVADV1C.487
DO I=I_start,I_end UVADV1C.488
NUX(I,K)=NUX_MIN(J-FIRST_ROW+1) UVADV1C.489
ENDDO UVADV1C.490
UVADV1C.491
ENDDO ! J : loop over rows UVADV1C.492
UVADV1C.493
! Set NUY equal to minimum value along each column UVADV1C.494
UVADV1C.495
DO J=FIRST_ROW_PT,LAST_ROW_PT GPB5F403.34
I_start=(FIRST_ROW-1)*ROW_LENGTH+J UVADV1C.498
! I_start points to the beginning of column J UVADV1C.499
UVADV1C.500
! Calculate the minimum along this column UVADV1C.501
*IF DEF,CRAY UVADV1C.502
IK=ISMIN(upd_U_ROWS,NUY(I_start,K),ROW_LENGTH) UVADV1C.503
SCALAR1=NUY((IK-1)*ROW_LENGTH+I_start,K) GPB5F403.35
*ELSE UVADV1C.505
I_end=I_start+(upd_U_ROWS-1)*ROW_LENGTH GPB5F403.36
! I_end points to the end of column J UVADV1C.507
SCALAR1=NUY(I_start,K) UVADV1C.508
DO I=I_start+ROW_LENGTH,I_end,ROW_LENGTH UVADV1C.509
IF (NUY(I,K) .LT. SCALAR1) SCALAR1=NUY(I,K) UVADV1C.510
ENDDO UVADV1C.511
*ENDIF UVADV1C.512
NUY_MIN(J)=SCALAR1 UVADV1C.513
UVADV1C.514
ENDDO ! J : loop over columns UVADV1C.515
UVADV1C.516
! Once again, this is only the minimum along our local part UVADV1C.517
! of each column. We must now find the miniumum of all the local UVADV1C.518
! minimums along the column UVADV1C.519
CALL GCG_RMIN(ROW_LENGTH-2*EW_Halo,GC_COL_GROUP,info, GPB5F403.37
& NUY_MIN(EW_Halo+1)) GPB5F403.38
UVADV1C.521
! and now set all values of NUY to the minimum along the column UVADV1C.522
DO J=FIRST_ROW_PT,LAST_ROW_PT GPB5F403.39
IF (NUY_MIN(J) .LT. 0.0) NUY_MIN(J)=0.0 UVADV1C.525
UVADV1C.526
I_start=(FIRST_ROW-1)*ROW_LENGTH+J UVADV1C.527
I_end=I_start+(upd_U_ROWS-1)*ROW_LENGTH GPB5F403.40
UVADV1C.529
DO I=I_start,I_end,ROW_LENGTH UVADV1C.530
NUY(I,K)=NUY_MIN(J) UVADV1C.531
ENDDO UVADV1C.532
UVADV1C.533
ENDDO ! J : loop over columns UVADV1C.534
UVADV1C.535
ENDIF ! IF its fourth order advection UVADV1C.536
UVADV1C.537
C --------------------------------------------------------------------- UVADV1C.538
CL SECTION 2.3 CALL ADV_U_GD TO OBTAIN FIRST INCREMENT DUE TO UVADV1C.539
CL ADVECTION. UVADV1C.540
C --------------------------------------------------------------------- UVADV1C.541
UVADV1C.542
KP=K+1 UVADV1C.543
KM=K-1 UVADV1C.544
IF (K .EQ. P_LEVELS) THEN UVADV1C.545
KP = K UVADV1C.546
END IF UVADV1C.547
IF (K .EQ. 1) THEN UVADV1C.548
KM = K UVADV1C.549
END IF UVADV1C.550
UVADV1C.551
C BRSP IS CURRENTLY HELD IN OMEGA UVADV1C.552
UVADV1C.553
UVADV1C.554
CALL ADV_U_GD(U(1,KM),U(1,K),U(1,KP), UVADV1C.555
& U_MEAN_P_COPY(1,K),V_MEAN_P_COPY(1,K), UVADV1C.556
& ETADOT_U(1,K),ETADOT_U(1,K+1), UVADV1C.557
& SEC_U_LATITUDE,U_FIRST_INC, UVADV1C.558
& NUX(1,K),NUY(1,K),U_FIELD, UVADV1C.559
& ROW_LENGTH, UVADV1C.560
*CALL ARGFLDPT UVADV1C.561
& TIMESTEP,LATITUDE_STEP_INVERSE, UVADV1C.562
& LONGITUDE_STEP_INVERSE,SEC_P_LATITUDE, UVADV1C.563
& OMEGA(1,K),L_SECOND,LWHITBROM, UVADV1C.564
& U_COPY(1,K),extended_U_FIELD, GSS1F403.726
& extended_address) GSS1F403.727
UVADV1C.566
CL CALL ADV_U_GD FOR V. UVADV1C.567
CALL ADV_U_GD(V(1,KM),V(1,K),V(1,KP), UVADV1C.568
& U_MEAN_P_COPY(1,K),V_MEAN_P_COPY(1,K), UVADV1C.569
& ETADOT_U(1,K),ETADOT_U(1,K+1), UVADV1C.570
& SEC_U_LATITUDE,V_FIRST_INC, UVADV1C.571
& NUX(1,K),NUY(1,K),U_FIELD, UVADV1C.572
& ROW_LENGTH, UVADV1C.573
*CALL ARGFLDPT UVADV1C.574
& TIMESTEP,LATITUDE_STEP_INVERSE, UVADV1C.575
& LONGITUDE_STEP_INVERSE,SEC_P_LATITUDE, UVADV1C.576
& OMEGA(1,K),L_SECOND,LWHITBROM, UVADV1C.577
& V_COPY(1,K),extended_U_FIELD, GSS1F403.728
& extended_address) GSS1F403.729
UVADV1C.579
C --------------------------------------------------------------------- UVADV1C.580
CL SECTION 2.4 REMOVE MASS-WEIGHTING FROM INCREMENT AND ADD ONTO UVADV1C.581
CL FIELD TO OBTAIN INTERMEDIATE VALUE. UVADV1C.582
C --------------------------------------------------------------------- UVADV1C.583
UVADV1C.584
DO I=1,START_POINT_NO_HALO-1 ADR2F402.24
U_PROV(I,K) = 0.0 ADR2F402.25
V_PROV(I,K) = 0.0 ADR2F402.26
ENDDO ADR2F402.27
ADR2F402.28
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO UVADV1C.585
SCALAR1 = 1./(RS_U(I,K)*RS_U(I,K) UVADV1C.586
& *(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I))) UVADV1C.587
U_PROV(I,K) = U(I,K)- U_FIRST_INC(I)*SCALAR1 UVADV1C.588
V_PROV(I,K) = V(I,K)-V_FIRST_INC(I)*SCALAR1 UVADV1C.589
ENDDO UVADV1C.590
UVADV1C.591
DO I=END_U_POINT_NO_HALO+1,U_FIELD ADR2F402.29
U_PROV(I,K) = 0.0 ADR2F402.30
V_PROV(I,K) = 0.0 ADR2F402.31
ENDDO ADR2F402.32
ADR2F402.33
*IF -DEF,GLOBAL UVADV1C.592
CL LIMITED AREA MODEL THEN FORM PROVISIONAL VALUES ON BOUNDARIES UVADV1C.593
CL EQUAL TO FIELD VALUES AT OLD TIME LEVEL. UVADV1C.594
IF (at_top_of_LPG) THEN UVADV1C.595
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 UVADV1C.596
U_PROV(I,K)= U(I,K) UVADV1C.597
V_PROV(I,K)= V(I,K) UVADV1C.598
ENDDO UVADV1C.599
ENDIF UVADV1C.600
IF (at_base_of_LPG) THEN UVADV1C.601
DO I=U_BOT_ROW_START,U_BOT_ROW_START+ROW_LENGTH-1 UVADV1C.602
U_PROV(I,K)=U(I,K) UVADV1C.603
V_PROV(I,K)=V(I,K) UVADV1C.604
ENDDO UVADV1C.605
ENDIF UVADV1C.606
*ENDIF UVADV1C.607
UVADV1C.608
ENDDO UVADV1C.609
UVADV1C.610
*IF DEF,GLOBAL UVADV1C.611
! IF GLOBAL MODEL CALCULATE PROVISIONAL POLAR VALUES. UVADV1C.612
! CALL POLAR_UV TO FORM PROVISIONAL VALUES. UVADV1C.613
UVADV1C.614
CALL POLAR_UV(U_PROV,V_PROV,ROW_LENGTH, UVADV1C.615
& U_FIELD,P_LEVELS, UVADV1C.616
*CALL ARGFLDPT UVADV1C.617
& COS_U_LONGITUDE,SIN_U_LONGITUDE) UVADV1C.618
*ENDIF UVADV1C.619
UVADV1C.620
! CALL SET_SIDES(U_PROV,P_FIELD,ROW_LENGTH,P_LEVELS,fld_type_u) UVADV1C.621
! CALL SET_SIDES(V_PROV,P_FIELD,ROW_LENGTH,P_LEVELS,fld_type_u) UVADV1C.622
UVADV1C.623
IF (L_SECOND) THEN UVADV1C.624
UVADV1C.625
! Swap boundaries of U_PROV and V_PROV UVADV1C.626
CALL SWAPBOUNDS(U_PROV,ROW_LENGTH,tot_U_ROWS, UVADV1C.627
& EW_Halo,NS_Halo,P_LEVELS) UVADV1C.628
CALL SWAPBOUNDS(V_PROV,ROW_LENGTH,tot_U_ROWS, UVADV1C.629
& EW_Halo,NS_Halo,P_LEVELS) UVADV1C.630
! CALL SET_SIDES(U_PROV,P_FIELD,ROW_LENGTH,P_LEVELS,fld_type_u) UVADV1C.631
! CALL SET_SIDES(V_PROV,P_FIELD,ROW_LENGTH,P_LEVELS,fld_type_u) UVADV1C.632
UVADV1C.633
ELSE ! fourth order advection UVADV1C.634
UVADV1C.635
! Copy U/V_PROV into U/V_COPY which have double halos for fourth UVADV1C.636
! order advection, and do swap to fill these halos UVADV1C.637
CALL COPY_FIELD(U_PROV,U_COPY, UVADV1C.638
& U_FIELD,extended_U_FIELD, UVADV1C.639
& ROW_LENGTH,tot_U_ROWS,P_LEVELS, UVADV1C.640
& EW_Halo,NS_Halo, UVADV1C.641
& halo_4th,halo_4th, UVADV1C.642
& .TRUE.) UVADV1C.643
UVADV1C.644
CALL COPY_FIELD(V_PROV,V_COPY, UVADV1C.645
& U_FIELD,extended_U_FIELD, UVADV1C.646
& ROW_LENGTH,tot_U_ROWS,P_LEVELS, UVADV1C.647
& EW_Halo,NS_Halo, UVADV1C.648
& halo_4th,halo_4th, UVADV1C.649
& .TRUE.) UVADV1C.650
UVADV1C.651
ENDIF UVADV1C.652
UVADV1C.653
DO K=1,P_LEVELS UVADV1C.654
CL--------------------------------------------------------------------- UVADV1C.655
CL SECTION 3. Second advection step. UVADV1C.656
CL--------------------------------------------------------------------- UVADV1C.657
UVADV1C.658
TIMESTEP = ADVECTION_TIMESTEP UVADV1C.659
C --------------------------------------------------------------------- UVADV1C.660
CL SECTION 3.1 CALL ADV_U_GD TO OBTAIN SECOND INCREMENT DUE TO UVADV1C.661
CL ADVECTION. UVADV1C.662
C --------------------------------------------------------------------- UVADV1C.663
UVADV1C.664
KP=K+1 UVADV1C.665
KM=K-1 UVADV1C.666
IF (K .EQ. P_LEVELS) THEN UVADV1C.667
KP = K UVADV1C.668
END IF UVADV1C.669
IF (K .EQ. 1) THEN UVADV1C.670
KM = K UVADV1C.671
END IF UVADV1C.672
UVADV1C.673
CL CALL ADV_U_GD FOR U. UVADV1C.674
UVADV1C.675
C BRSP IS CURRENTLY HELD IN OMEGA UVADV1C.676
UVADV1C.677
CALL ADV_U_GD(U_PROV(1,KM),U_PROV(1,K),U_PROV(1,KP), UVADV1C.678
& U_MEAN_P_COPY(1,K),V_MEAN_P_COPY(1,K), UVADV1C.679
& ETADOT_U(1,K),ETADOT_U(1,K+1),SEC_U_LATITUDE, UVADV1C.680
& U_SECOND_INC,NUX(1,K),NUY(1,K),U_FIELD, UVADV1C.681
& ROW_LENGTH, UVADV1C.682
*CALL ARGFLDPT UVADV1C.683
& TIMESTEP,LATITUDE_STEP_INVERSE, UVADV1C.684
& LONGITUDE_STEP_INVERSE,SEC_P_LATITUDE, UVADV1C.685
& OMEGA(1,K),L_SECOND,LWHITBROM, UVADV1C.686
& U_COPY(1,K),extended_U_FIELD, GSS1F403.730
& extended_address) GSS1F403.731
UVADV1C.688
CL CALL ADV_U_GD FOR V. UVADV1C.689
CALL ADV_U_GD(V_PROV(1,KM),V_PROV(1,K),V_PROV(1,KP), UVADV1C.690
& U_MEAN_P_COPY(1,K),V_MEAN_P_COPY(1,K), UVADV1C.691
& ETADOT_U(1,K),ETADOT_U(1,K+1),SEC_U_LATITUDE, UVADV1C.692
& V_SECOND_INC,NUX(1,K),NUY(1,K),U_FIELD, UVADV1C.693
& ROW_LENGTH, UVADV1C.694
*CALL ARGFLDPT UVADV1C.695
& TIMESTEP,LATITUDE_STEP_INVERSE, UVADV1C.696
& LONGITUDE_STEP_INVERSE,SEC_P_LATITUDE, UVADV1C.697
& OMEGA(1,K),L_SECOND,LWHITBROM, UVADV1C.698
& V_COPY(1,K),extended_U_FIELD, GSS1F403.732
& extended_address) GSS1F403.733
UVADV1C.700
C --------------------------------------------------------------------- UVADV1C.701
CL SECTION 3.2 CALL V_CORIOL TO OBTAIN WK AS IN EQUATION (46). UVADV1C.702
C --------------------------------------------------------------------- UVADV1C.703
UVADV1C.704
UVADV1C.705
CALL V_CORIOL(ETADOT_U(1,K),ETADOT_U(1,K+1),PSTAR, UVADV1C.706
& PSTAR_OLD,U_MEAN_P(1,K),V_MEAN_P(1,K),RS_U(1,K), UVADV1C.707
& SEC_U_LATITUDE,TIMESTEP,AK(K),BK(K), UVADV1C.708
& DELTA_AK(K),DELTA_BK(K),DELTA_AKH(K), UVADV1C.709
& DELTA_BKH(K),DELTA_AKH(K+1),DELTA_BKH(K+1), UVADV1C.710
& ROW_LENGTH, UVADV1C.711
*CALL ARGFLDPT UVADV1C.712
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, UVADV1C.713
& WK,U_FIELD,OMEGA(1,K),LLINTS) UVADV1C.714
UVADV1C.715
C --------------------------------------------------------------------- UVADV1C.716
CL SECTION 3.3 CALCULATE TOTAL MASS-WEIGHTED INCREMENT TO FIELD UVADV1C.717
CL INCLUDING CORIOLIS TERM AND ADD ONTO MASS-WEIGHTED UVADV1C.718
CL FIELD. UVADV1C.719
CL IF GLOBAL CALL POLAR_UV TO UPDATE POLAR VALUES. UVADV1C.720
CL IF LIMITED AREA MASS-WEIGHT BOUNDARY VALUES. UVADV1C.721
C --------------------------------------------------------------------- UVADV1C.722
UVADV1C.723
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO UVADV1C.724
SCALAR1=RS_U(I,K)*RS_U(I,K)* UVADV1C.725
& (DELTA_AK(K)+DELTA_BK(K)*PSTAR(I)) UVADV1C.726
U_SECOND_INC(I)=U_SECOND_INC(I)/SCALAR1 UVADV1C.727
V_SECOND_INC(I)=V_SECOND_INC(I)/SCALAR1 UVADV1C.728
WK(I)=WK(I)/SCALAR1 UVADV1C.729
END DO UVADV1C.730
CL TOTAL MASS-WEIGHTED INCREMENT IS CALCULATED INCLUDING VERTICAL UVADV1C.731
CL CORIOIS TERM AND ADDED ONTO MASS-WEIGHTED FIELD. UVADV1C.732
UVADV1C.733
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO UVADV1C.734
SCALAR3 = 1./RS_U(I,K) UVADV1C.735
U(I,K)=0.5 * (U(I,K)-U_SECOND_INC(I)+U_PROV(I,K)) UVADV1C.736
V(I,K)=0.5 * (V(I,K)-V_SECOND_INC(I)+V_PROV(I,K)) UVADV1C.737
ENDDO UVADV1C.738
IF (LWHITBROM) THEN UVADV1C.739
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO UVADV1C.740
SCALAR3 = 1.0/RS_U(I,K) UVADV1C.741
U(I,K) = U(I,K) -(F2(I) + U(I,K)*SCALAR3)*WK(I)*TIMESTEP UVADV1C.742
V(I,K) = V(I,K) +(F1(I) - V(I,K)*SCALAR3)*WK(I)*TIMESTEP UVADV1C.743
ENDDO UVADV1C.744
ENDIF UVADV1C.745
UVADV1C.746
CL SET POLAR VALUES FOR OMEGA UVADV1C.747
IF (at_top_of_LPG) THEN UVADV1C.748
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 UVADV1C.749
OMEGA(I,K)=OMEGA(I+ROW_LENGTH,K) UVADV1C.750
ENDDO UVADV1C.751
ENDIF UVADV1C.752
IF (at_base_of_LPG) THEN UVADV1C.753
DO I=U_BOT_ROW_START,U_BOT_ROW_START+ROW_LENGTH-1 UVADV1C.754
OMEGA(I,K)=OMEGA(I-ROW_LENGTH,K) UVADV1C.755
ENDDO UVADV1C.756
ENDIF UVADV1C.757
UVADV1C.758
CL END LOOP OVER P_LEVELS UVADV1C.759
ENDDO UVADV1C.760
UVADV1C.761
*IF DEF,GLOBAL UVADV1C.762
! UPDATE POLAR VALUES BY CALLING POLAR_UV. UVADV1C.763
UVADV1C.764
CALL POLAR_UV(U,V,ROW_LENGTH, UVADV1C.765
& U_FIELD,P_LEVELS, UVADV1C.766
*CALL ARGFLDPT UVADV1C.767
& COS_U_LONGITUDE,SIN_U_LONGITUDE) UVADV1C.768
*ENDIF UVADV1C.769
UVADV1C.770
CL MASS WEIGHT THE OUTPUT FIELDS UVADV1C.771
UVADV1C.772
DO K=1,P_LEVELS UVADV1C.773
DO I=FIRST_FLD_PT,LAST_U_FLD_PT UVADV1C.774
U(I,K)=U(I,K)*RS_U(I,K)*RS_U(I,K)*(DELTA_AK(K)+ UVADV1C.775
& DELTA_BK(K)*PSTAR(I)) UVADV1C.776
V(I,K)=V(I,K)*RS_U(I,K)*RS_U(I,K)*(DELTA_AK(K)+ UVADV1C.777
& DELTA_BK(K)*PSTAR(I)) UVADV1C.778
ENDDO UVADV1C.779
ENDDO UVADV1C.780
UVADV1C.781
CL END OF ROUTINE UV_ADV UVADV1C.782
UVADV1C.783
RETURN UVADV1C.784
END UVADV1C.785
*ENDIF ATJ0F402.16
*ENDIF UVADV1C.786