*IF DEF,A12_1B UVADV1B.2
C ******************************COPYRIGHT****************************** GTS2F400.10891
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10892
C GTS2F400.10893
C Use, duplication or disclosure of this code is subject to the GTS2F400.10894
C restrictions as set forth in the contract. GTS2F400.10895
C GTS2F400.10896
C Meteorological Office GTS2F400.10897
C London Road GTS2F400.10898
C BRACKNELL GTS2F400.10899
C Berkshire UK GTS2F400.10900
C RG12 2SZ GTS2F400.10901
C GTS2F400.10902
C If no contract has been raised with this copy of the code, the use, GTS2F400.10903
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10904
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10905
C Modelling at the above address. GTS2F400.10906
C ******************************COPYRIGHT****************************** GTS2F400.10907
C GTS2F400.10908
CLL SUBROUTINE UV_ADV ------------------------------------------- UVADV1B.3
CLL UVADV1B.4
CLL PURPOSE: UVADV1B.5
CLL CALCULATES MASS-WEIGHTED INCREMENTS TO U AND V DUE TO UVADV1B.6
CLL ADVECTION BY USING EQUATIONS (37) AND (38) TO CALCULATE UVADV1B.7
CLL PROVISIONAL VALUES OF U AND V AT THE NEW TIME-LEVEL, AND THEN UVADV1B.8
CLL RECALCULATING THE ADVECTION TERMS ON THE RIGHT-HAND SIDE OF (41) UVADV1B.9
CLL AND (42) USING THESE PROVISIONAL VALUES. THE CORIOLIS TERMS UVADV1B.10
CLL ASSOCIATED WITH THE VERTICAL VELOCITY ARE CALCULATED AND INCLUDED UVADV1B.11
CLL IN THE INCREMENTS. THE FINAL INCREMENTS ARE CALCULATED AS IN UVADV1B.12
CLL EQUATIONS (41) AND (42). IF RUNNING A GLOBAL MODEL POLAR_UV IS UVADV1B.13
CLL CALLED TO UPDATE POLAR VALUES. UVADV1B.14
CLL UVADV1B.15
CLL CHANGES INCLUDE:- UVADV1B.16
CLL U_MEAN AND V_MEAN FIELDS NOT OVER-WRITTEN WHEN INTERPOLATION TO UVADV1B.17
CLL U_GRID PERFORMED. ETADOT AND RS FIELDS INTERPOLATED TO U_GRID INSIDE UVADV1B.18
CLL THIS ROUTINE INSTEAD OF INSIDE ADV_CTL. THIS COSTS 8 EXTRA UVADV1B.19
CLL HORIZONTAL FIELDS BUT ALLOWS ROUTINE TO BE CALLED BEFORE TH_ADV SO UVADV1B.20
CLL THAT OMEGA CALCULATED HERE CAN BE USED INSIDE TH_ADV TO CALCULATE UVADV1B.21
CLL EXTRA THERMODYNAMIC TERM. UVADV1B.22
CLL UVADV1B.23
CLL INCLUSION OF L_SECOND TO CHOOSE CHEAPER SECOND ORDER ADVECTION UVADV1B.24
CLL SCHEME ALONG WITH REMOVAL OF CODE PREVIOUSLY UNDER *DEF FORECAST. UVADV1B.25
CLL UVADV1B.27
CLL NOT SUITABLE FOR SINGLE COLUMN USE. UVADV1B.28
CLL VERSION FOR CRAY Y-MP UVADV1B.29
CLL UVADV1B.30
CLL WRITTEN M.H MAWSON. UVADV1B.31
CLL UVADV1B.32
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: UVADV1B.33
CLL VERSION DATE UVADV1B.34
CLL 3.4 06/08/94 New release 1B with error in second order term UVADV1B.35
CLL corrected in addition to faster multi-tasked UVADV1B.36
CLL code achieved by inserting micro tasking UVADV1B.37
CLL directives and code restructuring UVADV1B.38
CLL to improve parallel efficiency on C90. UVADV1B.39
CLL X_FIELD passed as argument to reduce memory UVADV1B.40
CLL usage when 2nd order advection used. UVADV1B.41
CLL Authors: A. Dickinson, D. Salmond UVADV1B.42
CLL Reviewer: M. Mawson UVADV1B.43
CLL 3.4 28/10/94 Argument LLINTS added and passed to V_CORIOL UVADV1B.44
CLL Argument LWHITBROM added and passed to ADV_U_GD UVADV1B.45
CLL R.T.H.Barnes pp. S.J.Swarbrick UVADV1B.46
! 3.5 28/03/95 MPP code: Change updateable area and APB0F305.1030
! add boundary swaps. P.Burton APB0F305.1031
CLL UVADV1B.47
CLL 4.0 14/02/95 Option to run with half_timestep at top level ATD1F400.988
CLL removed. Author: T.Davies, Reviewer: M. Mawson ATD1F400.989
! 4.1 29/04/96 Remove MPP code (new QTADV1C version for MPP) APB0F401.1212
! and add TYPFLDPT arguments P.Burton APB0F401.1213
!LL 4.3 24/04/97 Fix to 4th order calculations - GPB5F403.41
!LL Calculation of NUY via ISMIN P.Burton GPB5F403.42
!LL 4.5 05/05/98 Recode -DEF,CRAY loops to find minimum of NUX/NUY GRB0F405.59
!LL to vectorize on Fujitsu VPP700. Also improve GRB0F405.60
!LL efficiency in section 3.3. RBarnes@ecmwf.int GRB0F405.61
!LL GRB0F405.62
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, UVADV1B.48
CLL STANDARD B. UVADV1B.49
CLL UVADV1B.50
CLL SYSTEM COMPONENTS COVERED: P122 UVADV1B.51
CLL UVADV1B.52
CLL SYSTEM TASK: P1 UVADV1B.53
CLL UVADV1B.54
CLL DOCUMENTATION: THE EQUATIONS USED ARE (37-38) AND (41-42) UVADV1B.55
CLL IN UNIFIED MODEL DOCUMENTATION PAPER NO. 10 UVADV1B.56
CLL M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON UVADV1B.57
CLL UVADV1B.58
CLLEND------------------------------------------------------------- UVADV1B.59
UVADV1B.60
C*L ARGUMENTS:--------------------------------------------------- UVADV1B.61
SUBROUTINE UV_ADV 2,59UVADV1B.62
& (U,V,PSTAR_OLD,PSTAR,U_MEAN,V_MEAN,SEC_U_LATITUDE, UVADV1B.63
& ETADOT_MEAN,RS,DELTA_AK,DELTA_BK,AK,BK,F1,F2, UVADV1B.64
& LATITUDE_STEP_INVERSE,ADVECTION_TIMESTEP,NU_BASIC, UVADV1B.65
& LONGITUDE_STEP_INVERSE,U_FIELD,P_FIELD, APB0F401.1214
& ROW_LENGTH,P_LEVELS, APB0F401.1215
*CALL ARGFLDPT 
APB0F401.1216
& COS_U_LONGITUDE,SIN_U_LONGITUDE,SEC_P_LATITUDE, APB0F401.1217
& AKH,BKH,OMEGA,L_SECOND,LLINTS, ATD1F400.990
& LWHITBROM,X_FIELD) UVADV1B.70
UVADV1B.71
IMPLICIT NONE UVADV1B.72
UVADV1B.73
INTEGER UVADV1B.74
& P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. UVADV1B.75
&, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID UVADV1B.76
&, X_FIELD !IN 1 IF 2ND ORDER ELSE U_FIELD UVADV1B.77
&, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. UVADV1B.79
&, ROW_LENGTH !IN NUMBER OF POINTS PER ROW UVADV1B.81
APB0F401.1218
! All TYPFLDPT arguments are intent IN APB0F401.1219
*CALL TYPFLDPT APB0F401.1220
UVADV1B.82
C LOGICAL VARIABLE UVADV1B.83
LOGICAL UVADV1B.84
& L_SECOND ! SET TO TRUE IF NU_BASIC IS ZERO. UVADV1B.85
& ,LLINTS ! Switch for linear TS calc in CALC_TS UVADV1B.88
& ,LWHITBROM ! Switch for White & Bromley terms UVADV1B.89
UVADV1B.90
REAL UVADV1B.91
& U_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED U VELOCITY UVADV1B.92
& ! FROM ADJUSTMENT STEP HELD AT U UVADV1B.93
& ! POINTS. UVADV1B.94
&,V_MEAN(U_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED V VELOCITY UVADV1B.95
& ! * COS(LAT) FROM ADJUSTMENT STEP UVADV1B.96
&,ETADOT_MEAN(P_FIELD,P_LEVELS) !IN AVERAGED MASS-WEIGHTED UVADV1B.97
& !VERTICAL VELOCITY FROM ADJUSTMENT STEP UVADV1B.98
UVADV1B.99
REAL UVADV1B.100
& U(U_FIELD,P_LEVELS) !INOUT IN U FIELD, UVADV1B.101
& ! OUT MASS-WEIGHTED U FIELD. UVADV1B.102
&,V(U_FIELD,P_LEVELS) !INOUT IN V FIELD, UVADV1B.103
& ! OUT MASS-WEIGHTED V FIELD. UVADV1B.104
UVADV1B.105
REAL UVADV1B.106
& PSTAR(U_FIELD) !IN PSTAR FIELD AT NEW TIME-LEVEL ON UVADV1B.107
& ! U GRID. UVADV1B.108
&,PSTAR_OLD(U_FIELD) !IN PSTAR AT PREVIOUS TIME-LEVEL ON UVADV1B.109
& ! U GRID. UVADV1B.110
&,RS(P_FIELD,P_LEVELS) !IN RS FIELD. UVADV1B.111
&,AK(P_LEVELS) !IN FIRST TERM IN HYBRID CO-ORDS. UVADV1B.112
&,BK(P_LEVELS) !IN SECOND TERM IN HYBRID CO-ORDS. UVADV1B.113
&,DELTA_AK(P_LEVELS) !IN LAYER THICKNESS UVADV1B.114
&,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS UVADV1B.115
&,AKH(P_LEVELS+1) !IN HYBRID CO-ORDINATE AT HALF LEVELS UVADV1B.116
&,BKH(P_LEVELS+1) !IN HYBRID CO-ORDINATE AT HALF LEVELS UVADV1B.117
&,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) UVADV1B.118
&,SEC_P_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT P POINTS (2-D ARRAY) UVADV1B.119
&,SIN_U_LONGITUDE(ROW_LENGTH) !IN SIN(LONGITUDE) AT U POINTS. UVADV1B.120
&,COS_U_LONGITUDE(ROW_LENGTH) !IN COS(LONGITUDE) AT U POINTS. UVADV1B.121
UVADV1B.122
REAL UVADV1B.123
& LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) UVADV1B.124
&,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) UVADV1B.125
&,ADVECTION_TIMESTEP !IN UVADV1B.126
&,NU_BASIC !IN STANDARD NU TERM FOR MODEL RUN. UVADV1B.127
&,F1(U_FIELD) !IN A CORIOLIS TERM (SEE DOCUMENTATION) UVADV1B.128
&,F2(U_FIELD) !IN A CORIOLIS TERM (SEE DOCUMENTATION) UVADV1B.129
UVADV1B.130
REAL UVADV1B.131
& OMEGA(U_FIELD,P_LEVELS) !OUT TRUE VERTICAL VELOCITY UVADV1B.132
C*--------------------------------------------------------------------- UVADV1B.133
UVADV1B.134
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- UVADV1B.135
C DEFINE LOCAL ARRAYS: 35 ARE REQUIRED UVADV1B.136
REAL UVADV1B.137
& RS_U(U_FIELD,P_LEVELS) ! RS AT U POINTS FOR CURRENT LEVE UVADV1B.138
&,ETADOT_U(U_FIELD,P_LEVELS+1) ! ETADOT AT U POINTS FOR CURRENT LE UVADV1B.139
&,U_MEAN_P(U_FIELD,P_LEVELS) ! U MEAN AT P POINTS FOR CURRENT LEVEL UVADV1B.140
& ! WITH FIRST POINT OF FIELD NOW UVADV1B.141
& ! BEING FIRST P POINT ON SECOND ROW UVADV1B.142
& ! OF P-GRID. UVADV1B.143
&,V_MEAN_P(U_FIELD,P_LEVELS) ! V MEAN AT P POINTS FOR CURRENT LEVEL UVADV1B.144
& ! WITH FIRST POINT OF FIELD NOW UVADV1B.145
& ! BEING FIRST P POINT ON SECOND ROW UVADV1B.146
& ! OF P-GRID. UVADV1B.147
UVADV1B.148
REAL UVADV1B.149
& U_FIRST_INC(U_FIELD) ! HOLDS U INCREMENT UVADV1B.150
& !RETURNED BY FIRST CALL TO ADV_U_GD UVADV1B.151
&,U_SECOND_INC(U_FIELD) ! HOLDS U INCREMENT UVADV1B.152
& !RETURNED BY SECOND CALL TO ADV_U_GD UVADV1B.153
&,U_PROV(U_FIELD,P_LEVELS) ! HOLDS PROVISIONAL VALUE OF UVADV1B.154
UVADV1B.155
REAL UVADV1B.156
& V_FIRST_INC(U_FIELD) ! HOLDS V INCREMENT UVADV1B.157
& !RETURNED BY FIRST CALL TO ADV_U_GD UVADV1B.158
&,V_SECOND_INC(U_FIELD) ! HOLDS V INCREMENT UVADV1B.159
& !RETURNED BY SECOND CALL TO ADV_U_GD UVADV1B.160
&,V_PROV(U_FIELD,P_LEVELS) ! HOLDS PROVISIONAL VALUE OF UVADV1B.161
UVADV1B.162
C NP DENOTES NORTH POLE, SP DENOTES SOUTH POLE. UVADV1B.163
C POLAR INCREMENT ARRAYS ARE NOT USED IN LIMITED AREA MODEL BUT TO UVADV1B.164
C REMOVE THEM WOULD LEAD TO MODIFYING THE NUMBER OF VARIABLES UVADV1B.165
C PASSED TO ADV_U_GD. THE RETENTION OF THESE ARRAYS ADDS ONLY UVADV1B.166
C 12*ROW_LENGTH TO THE SPACE USED AND NOTHING TO THE CALCULATION UVADV1B.167
C TIME AS ALL USES OF THEM IN CALCULATION ARE CONTROLLED BY *IF'S. UVADV1B.168
UVADV1B.169
REAL UVADV1B.170
& NUX(X_FIELD,P_LEVELS) ! COURANT NUMBER DEPENDENT NU AT U POI UVADV1B.171
& ! USED IN EAST-WEST ADVECTION. UVADV1B.172
&,NUY(X_FIELD,P_LEVELS) ! COURANT NUMBER DEPENDENT NU AT U POI UVADV1B.173
& ! USED IN NORTH-SOUTH ADVECTION. UVADV1B.174
UVADV1B.175
REAL UVADV1B.176
& DELTA_AKH(P_LEVELS+1) ! LAYER THICKNESS AK(K) - AK(K-1) UVADV1B.177
&,DELTA_BKH(P_LEVELS+1) ! LAYER THICKNESS BK(K) - BK(K-1) UVADV1B.178
&,WK(U_FIELD) ! WK AS IN EQUATION (46). UVADV1B.179
UVADV1B.180
C*--------------------------------------------------------------------- UVADV1B.181
C DEFINE LOCAL VARIABLES UVADV1B.182
INTEGER UVADV1B.183
& U_POINTS_UPDATE ! NUMBER OF U POINTS TO BE UPDATED. UVADV1B.184
& ! = (ROWS-1)*ROWLENGTH UVADV1B.185
UVADV1B.188
C REAL SCALARS UVADV1B.189
REAL UVADV1B.190
& SCALAR1,SCALAR2,SCALAR3,SCALAR4,TIMESTEP UVADV1B.191
UVADV1B.192
C COUNT VARIABLES FOR DO LOOPS ETC. UVADV1B.193
INTEGER UVADV1B.194
& I,I1,J,KP,KM,IK,K APB0F401.1221
UVADV1B.196
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- UVADV1B.197
EXTERNAL ADV_U_GD,POLAR_UV,V_CORIOL,UV_TO_P,P_TO_UV UVADV1B.198
*IF DEF,CRAY UVADV1B.199
INTEGER ISMIN UVADV1B.200
EXTERNAL ISMIN UVADV1B.201
*ENDIF UVADV1B.202
C*--------------------------------------------------------------------- UVADV1B.203
UVADV1B.204
CL MAXIMUM VECTOR LENGTH ASSUMED IS (ROWS+1) * ROWLENGTH UVADV1B.205
CL--------------------------------------------------------------------- UVADV1B.206
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: UVADV1B.207
CL--------------------------------------------------------------------- UVADV1B.208
CL UVADV1B.209
CL--------------------------------------------------------------------- UVADV1B.210
CL SECTION 1. INITIALISATION UVADV1B.211
CL--------------------------------------------------------------------- UVADV1B.212
C INCLUDE LOCAL CONSTANTS FROM GENERAL CONSTANTS BLOCK UVADV1B.213
UVADV1B.214
U_POINTS_UPDATE = upd_U_ROWS*ROW_LENGTH APB0F401.1222
DO K=1,P_LEVELS UVADV1B.218
CL INTERPOLATE RS ONTO U GRID. UVADV1B.219
CALL P_TO_UV(RS(1,K),RS_U(1,K),P_FIELD,U_FIELD,ROW_LENGTH, UVADV1B.220
& tot_P_ROWS) APB0F401.1223
ENDDO UVADV1B.222
UVADV1B.223
CL INTERPOLATE ETADOT ONTO U GRID AND INCLUDE BOTTOM AND TOP UVADV1B.224
CL BOUNDARY CONDITION UVADV1B.225
UVADV1B.226
DO K =2, P_LEVELS UVADV1B.227
CALL P_TO_UV(ETADOT_MEAN(1,K),ETADOT_U(1,K),P_FIELD,U_FIELD, UVADV1B.228
& ROW_LENGTH,tot_P_ROWS) APB0F401.1224
END DO UVADV1B.230
! Loop over field APB0F401.1225
DO I = FIRST_VALID_PT,LAST_U_VALID_PT APB0F401.1226
ETADOT_U(I,1) = 0. UVADV1B.232
ETADOT_U(I,P_LEVELS+1) = 0. UVADV1B.233
END DO UVADV1B.234
UVADV1B.235
IF (LWHITBROM) THEN UVADV1B.236
CL CALCULATE BRSP TERM AT LEVEL K UVADV1B.237
C STORE IN OMEGA TO SAVE WORKSPACE UVADV1B.238
UVADV1B.239
K=1 UVADV1B.240
! Loop over field APB0F401.1227
DO I=FIRST_VALID_PT,LAST_U_VALID_PT APB0F401.1228
OMEGA(I,K)=(3.*RS_U(I,K)+RS_U(I,K+1))*(RS_U(I,K)-RS_U(I,K+1)) UVADV1B.242
& *BKH(K+1)*.25*(PSTAR(I)-PSTAR_OLD(I)) UVADV1B.243
ENDDO UVADV1B.244
K=P_LEVELS UVADV1B.245
! Loop over field APB0F401.1229
DO I=FIRST_VALID_PT,LAST_U_VALID_PT APB0F401.1230
OMEGA(I,K)=-(3.*RS_U(I,K)+RS_U(I,K-1))*(RS_U(I,K)-RS_U(I,K-1)) UVADV1B.247
& *BKH(K)*.25*(PSTAR(I)-PSTAR_OLD(I)) UVADV1B.248
ENDDO UVADV1B.249
UVADV1B.250
DO K=2,P_LEVELS -1 UVADV1B.251
! Loop over field APB0F401.1231
DO I=FIRST_VALID_PT,LAST_U_VALID_PT APB0F401.1232
OMEGA(I,K)=((3.*RS_U(I,K)+RS_U(I,K+1)) UVADV1B.253
& *(RS_U(I,K)-RS_U(I,K+1))*BKH(K+1) UVADV1B.254
& *.25*(PSTAR(I)-PSTAR_OLD(I))) UVADV1B.255
& -((3.*RS_U(I,K)+RS_U(I,K-1)) UVADV1B.256
& *(RS_U(I,K)-RS_U(I,K-1))*BKH(K) UVADV1B.257
& *.25*(PSTAR(I)-PSTAR_OLD(I))) UVADV1B.258
ENDDO UVADV1B.259
UVADV1B.260
ENDDO UVADV1B.261
END IF UVADV1B.262
UVADV1B.263
CFPP$ NOCONCUR UVADV1B.274
DO I=2,P_LEVELS ATD1F400.992
DELTA_AKH(I) = AK(I) - AK(I-1) UVADV1B.276
DELTA_BKH(I) = BK(I) - BK(I-1) UVADV1B.277
END DO ATD1F400.993
C THESE ZERO VALUES SAVE HAVING TO PASS THE ZERO VERTICAL VELOCITIES UVADV1B.279
C ON LOWER AND UPPER BOUNDARIES TO V_CORIOL AS THE ZERO VELOCITIES ARE UVADV1B.280
C NOT HELD. (SEE CALL TO V_CORIOL IN SECTION 3.3) UVADV1B.281
DELTA_AKH(1) = 0. UVADV1B.282
DELTA_BKH(1) = 0. UVADV1B.283
DELTA_AKH(P_LEVELS+1) = 0. UVADV1B.284
DELTA_BKH(P_LEVELS+1) = 0. UVADV1B.285
UVADV1B.286
CL--------------------------------------------------------------------- UVADV1B.287
CL SECTION 2. ADVECTION OF U AND V. UVADV1B.288
CL SECTION 2 WILL CALCULATE PROVISIONAL VALUES OF UVADV1B.289
CL U AND V. SECTION 3 WILL CALCULATE FINAL VALUES. UVADV1B.290
CL--------------------------------------------------------------------- UVADV1B.291
UVADV1B.292
CL LOOP OVER P_LEVELS. UVADV1B.293
cmic$ parallel shared (advection_timestep, akh, bkh) UVADV1B.294
cmic$* shared(cos_u_longitude,sin_u_longitude) UVADV1B.295
cmic$* shared(longitude_step_inverse,latitude_step_inverse) UVADV1B.296
cmic$* shared(f1,f2,omega,delta_akh,delta_bkh,ak,bk) UVADV1B.297
cmic$* shared (delta_ak, delta_bk) UVADV1B.298
cmic$* shared (etadot_u, l_second, lwhitbrom, llints) UVADV1B.299
cmic$* shared (nu_basic, nux, nuy) UVADV1B.301
cmic$* shared (p_field, pstar) UVADV1B.302
cmic$* shared (pstar_old, p_levels) UVADV1B.303
cmic$* shared (row_length,rs_u, sec_p_latitude, sec_u_latitude) APB0F401.1233
*CALL CMICFLD APB0F401.1234
cmic$* shared (u,v, u_field, u_mean) UVADV1B.307
cmic$* shared (v_mean) UVADV1B.308
cmic$* private (u_first_inc,v_first_inc) UVADV1B.309
cmic$* shared (u_prov,v_prov) UVADV1B.310
cmic$* shared (u_mean_p,v_mean_p) UVADV1B.311
cmic$* private (const1, i, i1,wk) UVADV1B.312
cmic$* private (ik, j, k, km, kp, kappa_dum ) UVADV1B.313
cmic$* private (omega_p, p_exl_dum, p_exner_full, p_exu_dum, pk) UVADV1B.314
cmic$* private (pk1, pl_dum, pu_dum, scalar1, scalar2) UVADV1B.315
cmic$* private (scalar3,scalar4) UVADV1B.316
cmic$* private (u_second_inc, v_second_inc, timestep) UVADV1B.317
cmic$ do parallel UVADV1B.318
UVADV1B.319
DO K=1,P_LEVELS ATD1F400.994
UVADV1B.322
TIMESTEP = ADVECTION_TIMESTEP UVADV1B.323
UVADV1B.325
CL--------------------------------------------------------------------- UVADV1B.326
CL SECTION 2.0 INTERPOLATE U_MEAN AND V_MEAN TO P GRID. UVADV1B.327
CL INTERPOLATE RS AND ETADOT TO U GRID. UVADV1B.328
CL--------------------------------------------------------------------- UVADV1B.329
UVADV1B.330
CL INTERPOLATE U_MEAN ONTO P GRID. UVADV1B.331
UVADV1B.332
CALL UV_TO_P(U_MEAN(1,K),U_MEAN_P(1,K),U_FIELD,U_FIELD, UVADV1B.333
& ROW_LENGTH,upd_U_ROWS+2) APB0F401.1235
UVADV1B.335
CL INTERPOLATE V_MEAN ONTO P GRID. UVADV1B.336
UVADV1B.337
CALL UV_TO_P(V_MEAN(1,K),V_MEAN_P(1,K),U_FIELD,U_FIELD, UVADV1B.338
& ROW_LENGTH,upd_U_ROWS+2) APB0F401.1236
UVADV1B.340
C --------------------------------------------------------------------- UVADV1B.341
CL SECTION 2.1 SET NU DEPENDENT ON NU_BASIC AND MAX COURANT UVADV1B.342
CL NUMBER. UVADV1B.343
C --------------------------------------------------------------------- UVADV1B.344
CL IF NU_BASIC NOT EQUAL TO ZERO. UVADV1B.345
IF(.NOT.L_SECOND) THEN UVADV1B.346
CL THEN SET NU DEPENDENT ON NU_BASIC AND MAX UVADV1B.347
CL COURANT NUMBER. UVADV1B.348
CL CALCULATE COURANT NUMBER SQUARED. UVADV1B.349
! Loop over field missing top and bottom rows APB0F401.1237
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO APB0F401.1238
SCALAR1 = U_MEAN_P(I,K)*LONGITUDE_STEP_INVERSE UVADV1B.351
SCALAR2 = V_MEAN_P(I,K)*LATITUDE_STEP_INVERSE UVADV1B.352
SCALAR3 = TIMESTEP/ UVADV1B.353
& (RS_U(I,K)*RS_U(I,K)*(DELTA_AK(K)+DELTA_BK(K)* UVADV1B.354
& PSTAR_OLD(I))) UVADV1B.355
SCALAR4 = SEC_U_LATITUDE(I)*SCALAR3 UVADV1B.356
SCALAR1 = SCALAR1*SCALAR1 UVADV1B.357
SCALAR2 = SCALAR2*SCALAR2 UVADV1B.358
SCALAR3 = SCALAR3*SCALAR3 UVADV1B.359
SCALAR4 = SCALAR4*SCALAR4 UVADV1B.360
CL CALCULATE NU PARAMETER. UVADV1B.361
UVADV1B.362
NUX(I,K) = (1.- SCALAR4*SCALAR1)*NU_BASIC UVADV1B.363
NUY(I,K) = (1.- SCALAR3*SCALAR2)*NU_BASIC UVADV1B.364
END DO ATD1F400.996
C SET NUX EQUAL TO MINIMUM ALONG EACH ROW UVADV1B.366
DO J=1,upd_U_ROWS APB0F401.1239
I1 = START_POINT_NO_HALO + (J-1)*ROW_LENGTH APB0F401.1240
*IF DEF,CRAY UVADV1B.369
IK = ISMIN(ROW_LENGTH,NUX(I1,K),1) UVADV1B.370
SCALAR1 = NUX(IK+I1-1,K) UVADV1B.371
*ELSE UVADV1B.372
SCALAR1 = NUX(I1,K) GRB0F405.63
DO I=I1+1,I1+ROW_LENGTH-1 GRB0F405.64
IF(NUX(I,K).LT.SCALAR1) THEN GRB0F405.65
SCALAR1 = NUX(I,K) GRB0F405.66
END IF GRB0F405.67
END DO GRB0F405.68
*ENDIF UVADV1B.378
IF(SCALAR1.LT.0.) SCALAR1 = 0. UVADV1B.379
DO I=I1,I1+ROW_LENGTH-1 ATD1F400.999
NUX(I,K) = SCALAR1 UVADV1B.381
END DO ATD1F400.1000
END DO UVADV1B.383
UVADV1B.384
C SET NUY EQUAL TO MINIMUM ALONG EACH COLUMN UVADV1B.385
DO J=1,ROW_LENGTH UVADV1B.386
I1 = START_POINT_NO_HALO+ J-1 APB0F401.1241
*IF DEF,CRAY UVADV1B.388
IK = ISMIN(upd_U_ROWS,NUY(I1,K),ROW_LENGTH) APB0F401.1242
SCALAR1 = NUY((IK-1)*ROW_LENGTH+I1,K) GPB5F403.43
*ELSE UVADV1B.391
SCALAR1 = NUY(I1,K) GRB0F405.69
DO I=I1+ROW_LENGTH,END_U_POINT_NO_HALO,ROW_LENGTH GRB0F405.70
IF(NUY(I,K).LT.SCALAR1) THEN GRB0F405.71
SCALAR1 = NUY(I,K) GRB0F405.72
END IF GRB0F405.73
END DO GRB0F405.74
*ENDIF UVADV1B.397
IF(SCALAR1.LT.0.) SCALAR1 = 0. UVADV1B.398
DO I=I1,END_U_POINT_NO_HALO,ROW_LENGTH APB0F401.1244
NUY(I,K) = SCALAR1 UVADV1B.400
END DO UVADV1B.401
END DO UVADV1B.402
END IF UVADV1B.403
UVADV1B.404
C --------------------------------------------------------------------- UVADV1B.405
CL SECTION 2.3 CALL ADV_U_GD TO OBTAIN FIRST INCREMENT DUE TO UVADV1B.406
CL ADVECTION. UVADV1B.407
C --------------------------------------------------------------------- UVADV1B.408
UVADV1B.409
KP=K+1 UVADV1B.410
KM=K-1 UVADV1B.411
IF (K .EQ. P_LEVELS) THEN UVADV1B.412
KP = K UVADV1B.413
END IF UVADV1B.414
IF (K .EQ. 1) THEN UVADV1B.415
KM = K UVADV1B.416
END IF UVADV1B.417
UVADV1B.418
C BRSP IS CURRENTLY HELD IN OMEGA UVADV1B.419
UVADV1B.420
UVADV1B.421
CALL ADV_U_GD(U(1,KM),U(1,K),U(1,KP), UVADV1B.422
& U_MEAN_P(1,K),V_MEAN_P(1,K), UVADV1B.423
& ETADOT_U(1,K),ETADOT_U(1,K+1), UVADV1B.424
& SEC_U_LATITUDE,U_FIRST_INC, UVADV1B.425
& NUX(1,K),NUY(1,K),U_FIELD, UVADV1B.426
& ROW_LENGTH, APB0F401.1245
*CALL ARGFLDPT APB0F401.1246
& TIMESTEP,LATITUDE_STEP_INVERSE, UVADV1B.428
& LONGITUDE_STEP_INVERSE,SEC_P_LATITUDE, UVADV1B.429
& OMEGA(1,K),L_SECOND,LWHITBROM) UVADV1B.430
UVADV1B.431
CL CALL ADV_U_GD FOR V. UVADV1B.432
CALL ADV_U_GD(V(1,KM),V(1,K),V(1,KP), UVADV1B.433
& U_MEAN_P(1,K),V_MEAN_P(1,K), UVADV1B.434
& ETADOT_U(1,K),ETADOT_U(1,K+1), UVADV1B.435
& SEC_U_LATITUDE,V_FIRST_INC, UVADV1B.436
& NUX(1,K),NUY(1,K),U_FIELD, UVADV1B.437
& ROW_LENGTH, APB0F401.1247
*CALL ARGFLDPT APB0F401.1248
& TIMESTEP,LATITUDE_STEP_INVERSE, UVADV1B.439
& LONGITUDE_STEP_INVERSE,SEC_P_LATITUDE, UVADV1B.440
& OMEGA(1,K),L_SECOND,LWHITBROM) UVADV1B.441
UVADV1B.442
C --------------------------------------------------------------------- UVADV1B.443
CL SECTION 2.4 REMOVE MASS-WEIGHTING FROM INCREMENT AND ADD ONTO UVADV1B.444
CL FIELD TO OBTAIN INTERMEDIATE VALUE. UVADV1B.445
C --------------------------------------------------------------------- UVADV1B.446
UVADV1B.447
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO APB0F401.1249
SCALAR1 = 1./(RS_U(I,K)*RS_U(I,K) UVADV1B.449
& *(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I))) UVADV1B.450
U_PROV(I,K) = U(I,K)- U_FIRST_INC(I)*SCALAR1 UVADV1B.451
V_PROV(I,K) = V(I,K)-V_FIRST_INC(I)*SCALAR1 UVADV1B.452
END DO ATD1F400.1002
UVADV1B.454
*IF -DEF,GLOBAL APB2F401.210
CL LIMITED AREA MODEL THEN FORM PROVISIONAL VALUES ON BOUNDARIES UVADV1B.464
CL EQUAL TO FIELD VALUES AT OLD TIME LEVEL. UVADV1B.465
DO I=1,ROW_LENGTH ATD1F400.1003
IK = U_FIELD - ROW_LENGTH + I UVADV1B.467
U_PROV(I,K)= U(I,K) UVADV1B.468
V_PROV(I,K)= V(I,K) UVADV1B.469
U_PROV(IK,K)= U(IK,K) UVADV1B.470
V_PROV(IK,K)= V(IK,K) UVADV1B.471
END DO ATD1F400.1004
*ENDIF UVADV1B.473
UVADV1B.474
enddo UVADV1B.475
*IF DEF,GLOBAL APB2F401.211
! IF GLOBAL MODEL CALCULATE PROVISIONAL POLAR VALUES. APB2F401.212
! CALL POLAR_UV TO FORM PROVISIONAL VALUES. APB2F401.213
APB2F401.214
CALL POLAR_UV(U_PROV,V_PROV,ROW_LENGTH, APB2F401.215
& U_FIELD,P_LEVELS, APB2F401.216
*CALL ARGFLDPT APB2F401.217
& COS_U_LONGITUDE,SIN_U_LONGITUDE) APB2F401.218
*ENDIF APB2F401.219
cmic$ do parallel UVADV1B.476
DO K=1,P_LEVELS ATD1F400.1005
CL--------------------------------------------------------------------- UVADV1B.478
CL SECTION 3. Second advection step. UVADV1B.479
CL--------------------------------------------------------------------- UVADV1B.480
UVADV1B.482
TIMESTEP = ADVECTION_TIMESTEP UVADV1B.483
C --------------------------------------------------------------------- UVADV1B.487
CL SECTION 3.1 CALL ADV_U_GD TO OBTAIN SECOND INCREMENT DUE TO UVADV1B.488
CL ADVECTION. UVADV1B.489
C --------------------------------------------------------------------- UVADV1B.490
UVADV1B.491
KP=K+1 UVADV1B.492
KM=K-1 UVADV1B.493
IF (K .EQ. P_LEVELS) THEN UVADV1B.494
KP = K UVADV1B.495
END IF UVADV1B.496
IF (K .EQ. 1) THEN UVADV1B.497
KM = K UVADV1B.498
END IF UVADV1B.499
UVADV1B.500
CL CALL ADV_U_GD FOR U. UVADV1B.501
UVADV1B.502
C BRSP IS CURRENTLY HELD IN OMEGA UVADV1B.503
UVADV1B.504
CALL ADV_U_GD(U_PROV(1,KM),U_PROV(1,K),U_PROV(1,KP), UVADV1B.505
& U_MEAN_P(1,K),V_MEAN_P(1,K),ETADOT_U(1,K), UVADV1B.506
& ETADOT_U(1,K+1),SEC_U_LATITUDE, UVADV1B.507
& U_SECOND_INC,NUX(1,K),NUY(1,K),U_FIELD, UVADV1B.508
& ROW_LENGTH, APB0F401.1250
*CALL ARGFLDPT APB0F401.1251
& TIMESTEP,LATITUDE_STEP_INVERSE, UVADV1B.510
& LONGITUDE_STEP_INVERSE,SEC_P_LATITUDE, UVADV1B.511
& OMEGA(1,K), UVADV1B.512
& L_SECOND,LWHITBROM) UVADV1B.513
UVADV1B.514
CL CALL ADV_U_GD FOR V. UVADV1B.515
CALL ADV_U_GD(V_PROV(1,KM),V_PROV(1,K),V_PROV(1,KP), UVADV1B.516
& U_MEAN_P(1,K),V_MEAN_P(1,K),ETADOT_U(1,K), UVADV1B.517
& ETADOT_U(1,K+1),SEC_U_LATITUDE, UVADV1B.518
& V_SECOND_INC,NUX(1,K),NUY(1,K),U_FIELD, UVADV1B.519
& ROW_LENGTH, APB0F401.1252
*CALL ARGFLDPT APB0F401.1253
& TIMESTEP,LATITUDE_STEP_INVERSE, UVADV1B.521
& LONGITUDE_STEP_INVERSE,SEC_P_LATITUDE, UVADV1B.522
& OMEGA(1,K), UVADV1B.523
& L_SECOND,LWHITBROM) UVADV1B.524
UVADV1B.525
C --------------------------------------------------------------------- UVADV1B.526
CL SECTION 3.2 CALL V_CORIOL TO OBTAIN WK AS IN EQUATION (46). UVADV1B.527
C --------------------------------------------------------------------- UVADV1B.528
UVADV1B.529
UVADV1B.530
CALL V_CORIOL(ETADOT_U(1,K),ETADOT_U(1,K+1),PSTAR, UVADV1B.531
& PSTAR_OLD,U_MEAN_P(1,K),V_MEAN_P(1,K),RS_U(1,K), UVADV1B.532
& SEC_U_LATITUDE,TIMESTEP,AK(K),BK(K), UVADV1B.533
& DELTA_AK(K),DELTA_BK(K),DELTA_AKH(K), UVADV1B.534
& DELTA_BKH(K),DELTA_AKH(K+1),DELTA_BKH(K+1), UVADV1B.535
& ROW_LENGTH, APB0F401.1254
*CALL ARGFLDPT APB0F401.1255
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, UVADV1B.537
& WK,U_FIELD,OMEGA(1,K),LLINTS) UVADV1B.538
UVADV1B.539
C --------------------------------------------------------------------- UVADV1B.540
CL SECTION 3.3 CALCULATE TOTAL MASS-WEIGHTED INCREMENT TO FIELD UVADV1B.541
CL INCLUDING CORIOLIS TERM AND ADD ONTO MASS-WEIGHTED UVADV1B.542
CL FIELD. UVADV1B.543
CL IF GLOBAL CALL POLAR_UV TO UPDATE POLAR VALUES. UVADV1B.544
CL IF LIMITED AREA MASS-WEIGHT BOUNDARY VALUES. UVADV1B.545
C --------------------------------------------------------------------- UVADV1B.546
UVADV1B.547
! Loop over field, missing top and bottom rows APB0F401.1256
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO APB0F401.1257
SCALAR1=1.0/(RS_U(I,K)*RS_U(I,K)* GRB0F405.75
& (DELTA_AK(K)+DELTA_BK(K)*PSTAR(I))) GRB0F405.76
U_SECOND_INC(I)=U_SECOND_INC(I)*SCALAR1 GRB0F405.77
V_SECOND_INC(I)=V_SECOND_INC(I)*SCALAR1 GRB0F405.78
WK(I)=WK(I)*SCALAR1 GRB0F405.79
END DO UVADV1B.554
CL TOTAL MASS-WEIGHTED INCREMENT IS CALCULATED INCLUDING VERTICAL UVADV1B.555
CL CORIOIS TERM AND ADDED ONTO MASS-WEIGHTED FIELD. UVADV1B.556
UVADV1B.557
! Loop over field, missing top and bottom rows APB0F401.1258
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO APB0F401.1259
U(I,K)=0.5 * (U(I,K)-U_SECOND_INC(I)+U_PROV(I,K)) UVADV1B.560
UVADV1B.564
V(I,K)=0.5 * (V(I,K)-V_SECOND_INC(I)+V_PROV(I,K)) UVADV1B.565
END DO ATD1F400.1007
IF (LWHITBROM) THEN APB0F401.1260
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO APB0F401.1261
SCALAR3 = 1.0/RS_U(I,K) APB0F401.1262
U(I,K) = U(I,K) -(F2(I) + U(I,K)*SCALAR3)*WK(I)*TIMESTEP APB0F401.1263
V(I,K) = V(I,K) +(F1(I) - V(I,K)*SCALAR3)*WK(I)*TIMESTEP APB0F401.1264
ENDDO APB0F401.1265
ENDIF APB0F401.1266
CL SET POLAR VALUES FOR OMEGA UVADV1B.570
UVADV1B.571
DO I=1,ROW_LENGTH UVADV1B.572
OMEGA(I,K)=OMEGA(I+ROW_LENGTH,K) UVADV1B.573
OMEGA(U_FIELD-ROW_LENGTH+I,K)=OMEGA(U_FIELD-2*ROW_LENGTH UVADV1B.574
& +I,K) UVADV1B.575
END DO UVADV1B.576
UVADV1B.577
UVADV1B.578
UVADV1B.586
CL END LOOP OVER P_LEVELS UVADV1B.587
enddo UVADV1B.588
cmic$ end parallel UVADV1B.589
*IF DEF,GLOBAL APB2F401.220
! UPDATE POLAR VALUES BY CALLING POLAR_UV. APB2F401.221
APB2F401.222
CALL POLAR_UV(U,V,ROW_LENGTH,U_FIELD,P_LEVELS, APB2F401.223
*CALL ARGFLDPT APB2F401.224
& COS_U_LONGITUDE,SIN_U_LONGITUDE) APB2F401.225
*ENDIF APB2F401.226
UVADV1B.592
CL MASS WEIGHT THE OUTPUT FIELDS UVADV1B.593
DO K=1,P_LEVELS UVADV1B.594
DO I=FIRST_FLD_PT,LAST_U_FLD_PT APB0F401.1267
U(I,K)=U(I,K)*RS_U(I,K)*RS_U(I,K)*(DELTA_AK(K)+ UVADV1B.596
& DELTA_BK(K)*PSTAR(I)) UVADV1B.597
V(I,K)=V(I,K)*RS_U(I,K)*RS_U(I,K)*(DELTA_AK(K)+ UVADV1B.598
& DELTA_BK(K)*PSTAR(I)) UVADV1B.599
END DO UVADV1B.600
END DO UVADV1B.601
UVADV1B.602
CL END OF ROUTINE UV_ADV UVADV1B.603
UVADV1B.604
RETURN UVADV1B.605
END UVADV1B.606
*ENDIF UVADV1B.607