*IF DEF,A12_1B,OR,DEF,A12_1C,OR,DEF,A12_1E AAD2F404.250
C ******************************COPYRIGHT****************************** GTS2F400.11467
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.11468
C GTS2F400.11469
C Use, duplication or disclosure of this code is subject to the GTS2F400.11470
C restrictions as set forth in the contract. GTS2F400.11471
C GTS2F400.11472
C Meteorological Office GTS2F400.11473
C London Road GTS2F400.11474
C BRACKNELL GTS2F400.11475
C Berkshire UK GTS2F400.11476
C RG12 2SZ GTS2F400.11477
C GTS2F400.11478
C If no contract has been raised with this copy of the code, the use, GTS2F400.11479
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.11480
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.11481
C Modelling at the above address. GTS2F400.11482
C ******************************COPYRIGHT****************************** GTS2F400.11483
C GTS2F400.11484
CLL SUBROUTINE V_CORIOL ----------------------------------------- VCORIO1A.3
CLL VCORIO1A.4
CLL PURPOSE: CALCULATES APPROXIMATE VERTICAL VELOCITY AS IN VCORIO1A.5
CLL EQUATION (46) AT A MODEL LEVEL. VCORIO1A.6
CLL NOT SUITABLE FOR SINGLE COLUMN USE. VCORIO1A.7
CLL VERSION FOR CRAY Y-MP VCORIO1A.8
CLL VCORIO1A.9
CLL WRITTEN BY M.H MAWSON. VCORIO1A.10
CLL VCORIO1A.11
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: VCORIO1A.12
CLL VERSION DATE VCORIO1A.13
CLL 3.1 23/02/93 CORRECTION OF SIGN ERROR IN WK IR230293.1
CLL 3.1 02/02/93 CORRECTION OF SIGN ERROR IN DP_BY_DT IR020293.1
CLL 3.3 22/07/93 CORRECTIONS IN CALCULATION OF WP. SA220793.1
CLL 3.4 11/05/94 Argument LLINTS added and passed to CALC_TS GSS1F304.221
CLL S.J.Swarbrick GSS1F304.222
! 3.5 28/03/95 MPP code: Change updateable area P.Burton APB0F305.1117
! 4.1 25/04/96 Added TYPFLDPT arguments to dynamics routines APB0F401.1269
! which allows many of the differences between APB0F401.1270
! MPP and "normal" code to be at top level APB0F401.1271
! P.Burton APB0F401.1272
!LL 4.2 25/11/96 Corrections to allow LAM to run in MPP mode. ARB2F402.14
!LL RTHBarnes. ARB2F402.15
CLL VCORIO1A.14
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, VCORIO1A.15
CLL STANDARD B. VERSION 2, DATED 18/01/90 VCORIO1A.16
CLL VCORIO1A.17
CLL SYSTEM COMPONENTS COVERED: P124 VCORIO1A.18
CLL VCORIO1A.19
CLL SYSTEM TASK: P1 VCORIO1A.20
CLL VCORIO1A.21
CLL DOCUMENTATION: THE EQUATIONS USED ARE (44) TO (46) VCORIO1A.22
CLL IN UNIFIED MODEL DOCUMENTATION PAPER VCORIO1A.23
CLL NO. 10 M.J.P. CULLEN, T.DAVIES AND VCORIO1A.24
CLL M.H.MAWSON, VERSION 10, DATED 10/09/90. VCORIO1A.25
CLLEND------------------------------------------------------------- VCORIO1A.26
VCORIO1A.27
C*L ARGUMENTS:--------------------------------------------------- VCORIO1A.28
SUBROUTINE V_CORIOL 3,4VCORIO1A.29
1 (ETADOT_MINUS,ETADOT_PLUS,PSTAR,PSTAR_OLD, VCORIO1A.30
2 U,V,RS,SEC_U_LATITUDE,ADVECTION_TIMESTEP,AK, VCORIO1A.31
3 BK,DELTA_AK,DELTA_BK,DELTA_AKH_MINUS, VCORIO1A.32
4 DELTA_BKH_MINUS,DELTA_AKH_PLUS,DELTA_BKH_PLUS, VCORIO1A.33
5 ROW_LENGTH, APB0F401.1273
*CALL ARGFLDPT 
APB0F401.1274
6 LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, VCORIO1A.35
7 WK,U_FIELD,OMEGA,LLINTS) GSS1F304.223
VCORIO1A.37
IMPLICIT NONE VCORIO1A.38
VCORIO1A.39
INTEGER VCORIO1A.40
* U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID VCORIO1A.41
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW VCORIO1A.42
APB0F401.1275
! All TYPFLDPT arguments are intent IN APB0F401.1276
*CALL TYPFLDPT APB0F401.1277
APB0F401.1278
VCORIO1A.45
REAL VCORIO1A.46
* U(U_FIELD) !IN AVERAGED MASS-WEIGHTED U VELOCITY VCORIO1A.47
* ! FROM ADJUSTMENT STEP HELD AT P VCORIO1A.48
* ! POINTS WITH FIRST POINT OF FIELD VCORIO1A.49
* ! BEING FIRST P POINT ON SECOND ROW VCORIO1A.50
* ! OF P-GRID. VCORIO1A.51
*,V(U_FIELD) !IN AVERAGED MASS-WEIGHTED V VELOCITY VCORIO1A.52
* ! * COS(LAT) FROM ADJUSTMENT STEP VCORIO1A.53
* ! STORAGE AS FOR U_MEAN. VCORIO1A.54
*,ETADOT_PLUS(U_FIELD) !IN AVERAGED MASS-WEIGHTED VCORIO1A.55
* !VERTICAL VELOCITY FROM ADJUSTMENT STEP VCORIO1A.56
* ! AT LEVEL K+1/2. VCORIO1A.57
*,ETADOT_MINUS(U_FIELD) !IN AVERAGED MASS-WEIGHTED VCORIO1A.58
* !VERTICAL VELOCITY FROM ADJUSTMENT STEP VCORIO1A.59
* ! AT LEVEL K-1/2. VCORIO1A.60
VCORIO1A.61
REAL VCORIO1A.62
* PSTAR(U_FIELD) !IN PSTAR FIELD AT NEW TIME-LEVEL ON VCORIO1A.63
* ! U GRID. VCORIO1A.64
*,PSTAR_OLD(U_FIELD) !INPSTAR AT PREVIOUS TIME-LEVEL ON VCORIO1A.65
* ! U GRID. VCORIO1A.66
*,RS(U_FIELD) !IN RS FIELD ON U GRID. VCORIO1A.67
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) VCORIO1A.68
*,LONGITUDE_STEP_INVERSE !IN 1/LONGITUDE STEP VCORIO1A.69
*,LATITUDE_STEP_INVERSE !IN 1/LATITUDE STEP VCORIO1A.70
*,ADVECTION_TIMESTEP !IN VCORIO1A.71
VCORIO1A.72
REAL VCORIO1A.73
* WK(U_FIELD) !OUT WK AS IN EQUATION (46). VCORIO1A.74
*,OMEGA(U_FIELD) !OUT. HOLDS VERTICAL VELOCITY, OMEGA. VCORIO1A.75
VCORIO1A.76
VCORIO1A.77
REAL VCORIO1A.78
* AK !IN FIRST TERM IN HYBRID CO-ORDS. VCORIO1A.79
*,BK !IN SECOND TERM IN HYBRID CO-ORDS. VCORIO1A.80
*,DELTA_AK !IN LAYER THICKNESS VCORIO1A.81
*,DELTA_BK !IN LAYER THICKNESS VCORIO1A.82
*,DELTA_AKH_MINUS !IN LAYER THICKNESS AK(K) - AK(K-1) VCORIO1A.83
*,DELTA_BKH_MINUS !IN LAYER THICKNESS BK(K) - BK(K-1) VCORIO1A.84
*,DELTA_AKH_PLUS !IN LAYER THICKNESS AK(K+1) - AK(K) VCORIO1A.85
*,DELTA_BKH_PLUS !IN LAYER THICKNESS BK(K+1) - BK(K) VCORIO1A.86
C*--------------------------------------------------------------------- VCORIO1A.87
VCORIO1A.88
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- VCORIO1A.89
C DEFINE LOCAL ARRAYS: 5 ARE REQUIRED VCORIO1A.90
VCORIO1A.91
REAL VCORIO1A.92
* DP_BY_DT(U_FIELD) VCORIO1A.93
*,WP(U_FIELD) VCORIO1A.94
*,WORK1(U_FIELD) VCORIO1A.95
*,WORK2(U_FIELD) VCORIO1A.96
*,TS(U_FIELD) VCORIO1A.97
VCORIO1A.98
C*--------------------------------------------------------------------- VCORIO1A.99
C DEFINE LOCAL VARIABLES VCORIO1A.100
REAL VCORIO1A.101
* SCALAR VCORIO1A.102
VCORIO1A.103
C COUNT VARIABLES FOR DO LOOPS ETC. VCORIO1A.104
INTEGER VCORIO1A.105
* I,J,POINTS SA220793.2
VCORIO1A.107
C LOGICAL VARIABLES VCORIO1A.108
LOGICAL VCORIO1A.109
* CONSTANT_PRESSURE VCORIO1A.110
*,LLINTS ! Switch for linear TS calc in CALC_TS GSS1F304.224
VCORIO1A.111
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- VCORIO1A.112
EXTERNAL CALC_TS VCORIO1A.113
C*--------------------------------------------------------------------- VCORIO1A.114
CL CALL COMDECK TO OBTAIN CONSTANTS USED. VCORIO1A.115
VCORIO1A.116
*CALL C_VCORI VCORIO1A.117
VCORIO1A.118
CL MAXIMUM VECTOR LENGTH ASSUMED IS END_U_UPDATE+ROW_LENGTH+1- VCORIO1A.119
CL START_U_UPDATE VCORIO1A.120
CL--------------------------------------------------------------------- VCORIO1A.121
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: VCORIO1A.122
CL--------------------------------------------------------------------- VCORIO1A.123
CL VCORIO1A.124
CL--------------------------------------------------------------------- VCORIO1A.125
CL SECTION 1. CALCULATE DP/DT VCORIO1A.126
CL--------------------------------------------------------------------- VCORIO1A.127
VCORIO1A.128
IF(BK.EQ.0.) THEN VCORIO1A.129
C A CONSTANT PRESSURE LEVEL SO DP/DT IS ZERO. VCORIO1A.130
CONSTANT_PRESSURE = .TRUE. VCORIO1A.131
! Loop over U field missing top and bottom rows and halos APB0F401.1279
DO 100 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO APB0F401.1280
DP_BY_DT(I) = 0. VCORIO1A.133
100 CONTINUE VCORIO1A.134
ELSE VCORIO1A.135
C CALCULATE DP/DT. VCORIO1A.136
CONSTANT_PRESSURE = .FALSE. VCORIO1A.137
SCALAR = BK/ADVECTION_TIMESTEP VCORIO1A.138
! Loop over U field missing top and bottom rows and halos APB0F401.1281
DO 110 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO APB0F401.1282
DP_BY_DT(I) = (DELTA_AK+DELTA_BK*PSTAR_OLD(I))*RS(I)*RS(I) VCORIO1A.140
* *(PSTAR(I)-PSTAR_OLD(I))*SCALAR VCORIO1A.141
110 CONTINUE VCORIO1A.142
END IF VCORIO1A.143
VCORIO1A.144
CL--------------------------------------------------------------------- VCORIO1A.145
CL SECTION 2. CALCULATE U.GRAD P VCORIO1A.146
CL--------------------------------------------------------------------- VCORIO1A.147
VCORIO1A.148
C---------------------------------------------------------------------- VCORIO1A.149
CL SECTION 2.1 CALCULATE U DP/D(LONGITUDE) VCORIO1A.150
C---------------------------------------------------------------------- VCORIO1A.151
VCORIO1A.152
C CALCULATE U DP/D(LONGITUDE) BETWEEN P POINTS VCORIO1A.153
! Loop over U field missing top and bottom rows and halos and APB0F401.1283
! last point APB0F401.1284
DO 210 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 APB0F401.1285
WORK1(I) = .5*(U(I+1)+U(I+1-ROW_LENGTH))*(PSTAR(I+1)-PSTAR(I))* SA220793.4
* LONGITUDE_STEP_INVERSE*BK VCORIO1A.156
210 CONTINUE VCORIO1A.157
VCORIO1A.158
*IF DEF,GLOBAL VCORIO1A.159
*IF -DEF,MPP APB0F305.1122
C GLOBAL MODEL SO RECALCULATE VALUE AT END-POINT VCORIO1A.160
! Loop ove the last point of each row missing top and bottom rows APB0F401.1286
! and halos. APB0F401.1287
DO 212 I=START_POINT_NO_HALO+LAST_ROW_PT-1, APB0F401.1288
& END_U_POINT_NO_HALO,ROW_LENGTH APB0F401.1289
WORK1(I) = .5*(U(I+1-ROW_LENGTH)+U(I+1-2*ROW_LENGTH))* SA220793.5
* (PSTAR(I+1-ROW_LENGTH)-PSTAR(I))* SA220793.6
* LONGITUDE_STEP_INVERSE*BK SA220793.7
212 CONTINUE VCORIO1A.164
*ELSE APB0F305.1123
WORK1(END_U_POINT_NO_HALO) = 0.0 APB0F401.1290
! MPP Code : No need to do recalculations of end points because cyclic APB0F305.1125
! boundary conditions means that halos do this for us automatically APB0F305.1126
APB0F305.1127
*ENDIF APB0F305.1128
*ELSE SA220793.8
WORK1(END_U_POINT_NO_HALO) = 0.0 APB0F401.1291
*ENDIF VCORIO1A.165
VCORIO1A.166
C CALCULATE U DP/D(LONGITUDE) AT P POINTS VCORIO1A.167
VCORIO1A.168
! Loop over U field missing top and bottom rows and halos and APB0F401.1292
! first point APB0F401.1293
DO 214 I=START_POINT_NO_HALO+1,END_U_POINT_NO_HALO APB0F401.1294
WP(I) = .5*(WORK1(I)+WORK1(I-1)) VCORIO1A.170
214 CONTINUE VCORIO1A.171
VCORIO1A.172
C---------------------------------------------------------------------- VCORIO1A.173
CL SECTION 2.2 CALCULATE V DP/D(LATITUDE) AND HENCE U.GRAD P VCORIO1A.174
C---------------------------------------------------------------------- VCORIO1A.175
VCORIO1A.176
C CALCULATE V DP/D(LATITUDE) BETWEEN P POINTS. VCORIO1A.177
VCORIO1A.178
! Loop over U field missing bottom row, last point and top and APB0F401.1295
! bottom halos APB0F401.1296
DO 220 I=START_POINT_NO_HALO-ROW_LENGTH,END_U_POINT_NO_HALO-1 APB0F401.1297
WORK2(I) = .5*(V(I)+V(I+1))*(PSTAR(I)-PSTAR(I+ROW_LENGTH)) SA220793.11
* *LATITUDE_STEP_INVERSE*BK VCORIO1A.181
220 CONTINUE VCORIO1A.182
VCORIO1A.183
VCORIO1A.185
*IF -DEF,MPP APB0F305.1129
! Last point of row above START_POINT row APB0F401.1298
I = START_POINT_NO_HALO-ROW_LENGTH+LAST_ROW_PT-1 APB0F401.1299
C GLOBAL MODEL SO RECALCULATE LAST POINT VALUES FOR V DP/D(LAT) SA220793.13
SA220793.14
WORK2(I) = .5*(V(I)+V(I+1-ROW_LENGTH))*(PSTAR(I)- SA220793.15
* PSTAR(I+ROW_LENGTH))*LATITUDE_STEP_INVERSE*BK VCORIO1A.190
VCORIO1A.191
! Loop over first point of each row, missing top and bottom rows and APB0F401.1300
! halos APB0F401.1301
DO 222 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO,ROW_LENGTH APB0F401.1302
VCORIO1A.193
! I is the first point of the row, J will be the last point on the row APB0F401.1303
J = I+LAST_ROW_PT-1 APB0F401.1304
SA220793.17
WORK2(J) = .5*(V(J)+V(I))*(PSTAR(J)-PSTAR(J+ROW_LENGTH))* SA220793.18
* LATITUDE_STEP_INVERSE*BK SA220793.19
VCORIO1A.196
C AND U DP/D(LONG) AT P POINTS. VCORIO1A.197
WP(I) = .5*(WORK1(I)+WORK1(I-1+ROW_LENGTH)) VCORIO1A.198
222 CONTINUE VCORIO1A.199
*ELSE APB0F305.1130
WORK2(END_U_POINT_NO_HALO)=WORK2(END_U_POINT_NO_HALO-1) APB0F401.1305
WP(START_POINT_NO_HALO)=WP(START_POINT_NO_HALO+1) APB0F401.1306
! MPP Code : No need to do recalculations of end points because cyclic APB0F305.1133
! boundary conditions means that halos do this for us automatically APB0F305.1134
APB0F305.1135
*ENDIF APB0F305.1136
VCORIO1A.200
VCORIO1A.202
C CALCULATE U.GRAD P VCORIO1A.203
VCORIO1A.204
*IF DEF,GLOBAL,OR,DEF,MPP ARB2F402.16
! Loop over field, missing top and bottom rows and halos APB0F401.1307
DO 224 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO APB0F401.1308
*ELSE VCORIO1A.207
! Loop over field, missing top and bottom rows and halos, and first APB0F401.1309
! and last points. APB0F401.1310
DO 224 I=START_POINT_NO_HALO+1,END_U_POINT_NO_HALO-1 APB0F401.1311
*ENDIF VCORIO1A.209
WP(I)=(WP(I)+.5*(WORK2(I)+WORK2(I-ROW_LENGTH))) VCORIO1A.210
* *SEC_U_LATITUDE(I) VCORIO1A.211
224 CONTINUE VCORIO1A.212
VCORIO1A.213
CL--------------------------------------------------------------------- VCORIO1A.214
CL SECTION 3. CALL CALC_TS TO GET TS. VCORIO1A.215
CL--------------------------------------------------------------------- VCORIO1A.216
VCORIO1A.217
C STORE PRESSURE IN WORK. VCORIO1A.218
! Loop over field, missing top and bottom rows and halos APB0F401.1312
DO 300 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO APB0F401.1313
WORK2(I) = AK + BK*PSTAR(I) VCORIO1A.220
300 CONTINUE VCORIO1A.221
VCORIO1A.222
C CALCULATE NUMBER OF POINTS CALC_TS TO BE CALLED FOR. VCORIO1A.223
POINTS = END_U_POINT_NO_HALO-START_POINT_NO_HALO+1 APB0F401.1314
VCORIO1A.225
C TS IS RETURNED IN WORK. VCORIO1A.226
VCORIO1A.227
CALL CALC_TS(WORK2(START_POINT_NO_HALO),TS(START_POINT_NO_HALO), APB0F401.1315
& POINTS,CONSTANT_PRESSURE,LLINTS) APB0F401.1316
VCORIO1A.230
CL--------------------------------------------------------------------- VCORIO1A.231
CL SECTION 4. CALCULATE WK AS IN EQUATION (43). VCORIO1A.232
CL--------------------------------------------------------------------- VCORIO1A.233
VCORIO1A.234
*IF DEF,GLOBAL,OR,DEF,MPP ARB2F402.17
! Loop over field, missing top and bottom rows and halos APB0F401.1317
DO 400 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO APB0F401.1318
*ELSE VCORIO1A.237
DO 400 I=START_POINT_NO_HALO+1,END_U_POINT_NO_HALO-1 APB0F401.1319
*ENDIF VCORIO1A.239
OMEGA(I)= WP(I)+DP_BY_DT(I)+.5*(ETADOT_PLUS(I)* IR020293.2
* (DELTA_AKH_PLUS+DELTA_BKH_PLUS*PSTAR(I))+ETADOT_MINUS(I) VCORIO1A.241
* *(DELTA_AKH_MINUS+DELTA_BKH_MINUS*PSTAR(I))) VCORIO1A.242
WK(I) = -R*TS(I)*OMEGA(I)/(G*WORK2(I)) IR230293.2
400 CONTINUE VCORIO1A.244
VCORIO1A.245
*IF -DEF,GLOBAL VCORIO1A.246
VCORIO1A.247
CL LIMITED AREA MODEL SET VERTICAL VELOCITY ON BOUNDARY TO ZERO. VCORIO1A.248
VCORIO1A.249
*IF DEF,MPP APB0F401.1320
IF (at_left_of_LPG) THEN APB0F401.1321
*ENDIF APB0F401.1322
! Set first point of each row to zero APB0F401.1323
DO I=START_POINT_NO_HALO+FIRST_ROW_PT-1,END_U_POINT_NO_HALO, APB0F401.1324
& ROW_LENGTH APB0F401.1325
WK(I)=0.0 APB0F401.1326
OMEGA(I)=0.0 APB0F401.1327
*IF -DEF,GLOBAL ARB2F402.18
WK(I-1)=0.0 ARB2F402.19
OMEGA(I-1)=0.0 ARB2F402.20
*ENDIF ARB2F402.21
ENDDO APB0F401.1328
*IF DEF,MPP APB0F401.1329
ENDIF APB0F401.1330
APB0F401.1331
IF (at_right_of_LPG) THEN APB0F401.1332
*ENDIF APB0F401.1333
! Set last two points of each row to zero APB0F401.1334
DO I=START_POINT_NO_HALO+LAST_ROW_PT-2,END_U_POINT_NO_HALO, APB0F401.1335
& ROW_LENGTH APB0F401.1336
WK(I)=0.0 APB0F401.1337
WK(I+1)=0.0 APB0F401.1338
OMEGA(I)=0.0 APB0F401.1339
OMEGA(I+1)=0.0 APB0F401.1340
*IF -DEF,GLOBAL ARB2F402.22
WK(I+2)=0.0 ARB2F402.23
OMEGA(I+2)=0.0 ARB2F402.24
*ENDIF ARB2F402.25
ENDDO APB0F401.1341
*IF DEF,MPP APB0F401.1342
ENDIF APB0F401.1343
*ENDIF APB0F401.1344
VCORIO1A.258
*ENDIF VCORIO1A.259
VCORIO1A.260
CL END OF ROUTINE V_CORIOL VCORIO1A.261
VCORIO1A.262
RETURN VCORIO1A.263
END VCORIO1A.264
VCORIO1A.265
*ENDIF VCORIO1A.266