*IF DEF,A12_1D VCORIO1D.2
C ******************************COPYRIGHT****************************** VCORIO1D.3
C (c) CROWN COPYRIGHT 1996, METEOROLOGICAL OFFICE, All Rights Reserved. VCORIO1D.4
C VCORIO1D.5
C Use, duplication or disclosure of this code is subject to the VCORIO1D.6
C restrictions as set forth in the contract. VCORIO1D.7
C VCORIO1D.8
C Meteorological Office VCORIO1D.9
C London Road VCORIO1D.10
C BRACKNELL VCORIO1D.11
C Berkshire UK VCORIO1D.12
C RG12 2SZ VCORIO1D.13
C VCORIO1D.14
C If no contract has been raised with this copy of the code, the use, VCORIO1D.15
C duplication or disclosure of it is strictly prohibited. Permission VCORIO1D.16
C to do so must first be obtained in writing from the Head of Numerical VCORIO1D.17
C Modelling at the above address. VCORIO1D.18
C ******************************COPYRIGHT****************************** VCORIO1D.19
C VCORIO1D.20
CLL SUBROUTINE V_CORIOL ----------------------------------------- VCORIO1D.21
CLL VCORIO1D.22
CLL PURPOSE: CALCULATES APPROXIMATE VERTICAL VELOCITY AS IN VCORIO1D.23
CLL EQUATION (46) AT A MODEL LEVEL. VCORIO1D.24
CLL NOT SUITABLE FOR SINGLE COLUMN USE. VCORIO1D.25
CLL VERSION FOR CRAY Y-MP VCORIO1D.26
CLL VCORIO1D.27
CLL WRITTEN BY M.H MAWSON. VCORIO1D.28
CLL VCORIO1D.29
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 4.2: ATJ0F403.185
CLL VERSION DATE VCORIO1D.31
!LL 4.2 25/10/96 New deck for HADCM2-specific section A12_1D, VCORIO1D.32
!LL as VCORIO1A but with reintroduced errors in VCORIO1D.33
!LL calculation of WP, loops 210,212,220,222 and 224. VCORIO1D.34
!LL T.Johns VCORIO1D.35
!LL 4.3 10/04/97 Updated in line with MPP optimisations. T.Johns ATJ0F403.186
CLL VCORIO1D.36
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, VCORIO1D.37
CLL STANDARD B. VERSION 2, DATED 18/01/90 VCORIO1D.38
CLL VCORIO1D.39
CLL SYSTEM COMPONENTS COVERED: P124 VCORIO1D.40
CLL VCORIO1D.41
CLL SYSTEM TASK: P1 VCORIO1D.42
CLL VCORIO1D.43
CLL DOCUMENTATION: THE EQUATIONS USED ARE (44) TO (46) VCORIO1D.44
CLL IN UNIFIED MODEL DOCUMENTATION PAPER VCORIO1D.45
CLL NO. 10 M.J.P. CULLEN, T.DAVIES AND VCORIO1D.46
CLL M.H.MAWSON, VERSION 10, DATED 10/09/90. VCORIO1D.47
CLLEND------------------------------------------------------------- VCORIO1D.48
VCORIO1D.49
C*L ARGUMENTS:--------------------------------------------------- VCORIO1D.50
SUBROUTINE V_CORIOL 3,4VCORIO1D.51
1 (ETADOT_MINUS,ETADOT_PLUS,PSTAR,PSTAR_OLD, VCORIO1D.52
2 U,V,RS,SEC_U_LATITUDE,ADVECTION_TIMESTEP,AK, VCORIO1D.53
3 BK,DELTA_AK,DELTA_BK,DELTA_AKH_MINUS, VCORIO1D.54
4 DELTA_BKH_MINUS,DELTA_AKH_PLUS,DELTA_BKH_PLUS, VCORIO1D.55
5 ROW_LENGTH, VCORIO1D.56
*CALL ARGFLDPT 
VCORIO1D.57
6 LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, VCORIO1D.58
7 WK,U_FIELD,OMEGA,LLINTS) VCORIO1D.59
VCORIO1D.60
IMPLICIT NONE VCORIO1D.61
VCORIO1D.62
INTEGER VCORIO1D.63
* U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID VCORIO1D.64
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW VCORIO1D.65
VCORIO1D.66
! All TYPFLDPT arguments are intent IN VCORIO1D.67
*CALL TYPFLDPT VCORIO1D.68
VCORIO1D.69
VCORIO1D.70
REAL VCORIO1D.71
* U(U_FIELD) !IN AVERAGED MASS-WEIGHTED U VELOCITY VCORIO1D.72
* ! FROM ADJUSTMENT STEP HELD AT P VCORIO1D.73
* ! POINTS WITH FIRST POINT OF FIELD VCORIO1D.74
* ! BEING FIRST P POINT ON SECOND ROW VCORIO1D.75
* ! OF P-GRID. VCORIO1D.76
*,V(U_FIELD) !IN AVERAGED MASS-WEIGHTED V VELOCITY VCORIO1D.77
* ! * COS(LAT) FROM ADJUSTMENT STEP VCORIO1D.78
* ! STORAGE AS FOR U_MEAN. VCORIO1D.79
*,ETADOT_PLUS(U_FIELD) !IN AVERAGED MASS-WEIGHTED VCORIO1D.80
* !VERTICAL VELOCITY FROM ADJUSTMENT STEP VCORIO1D.81
* ! AT LEVEL K+1/2. VCORIO1D.82
*,ETADOT_MINUS(U_FIELD) !IN AVERAGED MASS-WEIGHTED VCORIO1D.83
* !VERTICAL VELOCITY FROM ADJUSTMENT STEP VCORIO1D.84
* ! AT LEVEL K-1/2. VCORIO1D.85
VCORIO1D.86
REAL VCORIO1D.87
* PSTAR(U_FIELD) !IN PSTAR FIELD AT NEW TIME-LEVEL ON VCORIO1D.88
* ! U GRID. VCORIO1D.89
*,PSTAR_OLD(U_FIELD) !INPSTAR AT PREVIOUS TIME-LEVEL ON VCORIO1D.90
* ! U GRID. VCORIO1D.91
*,RS(U_FIELD) !IN RS FIELD ON U GRID. VCORIO1D.92
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) VCORIO1D.93
*,LONGITUDE_STEP_INVERSE !IN 1/LONGITUDE STEP VCORIO1D.94
*,LATITUDE_STEP_INVERSE !IN 1/LATITUDE STEP VCORIO1D.95
*,ADVECTION_TIMESTEP !IN VCORIO1D.96
VCORIO1D.97
REAL VCORIO1D.98
* WK(U_FIELD) !OUT WK AS IN EQUATION (46). VCORIO1D.99
*,OMEGA(U_FIELD) !OUT. HOLDS VERTICAL VELOCITY, OMEGA. VCORIO1D.100
VCORIO1D.101
VCORIO1D.102
REAL VCORIO1D.103
* AK !IN FIRST TERM IN HYBRID CO-ORDS. VCORIO1D.104
*,BK !IN SECOND TERM IN HYBRID CO-ORDS. VCORIO1D.105
*,DELTA_AK !IN LAYER THICKNESS VCORIO1D.106
*,DELTA_BK !IN LAYER THICKNESS VCORIO1D.107
*,DELTA_AKH_MINUS !IN LAYER THICKNESS AK(K) - AK(K-1) VCORIO1D.108
*,DELTA_BKH_MINUS !IN LAYER THICKNESS BK(K) - BK(K-1) VCORIO1D.109
*,DELTA_AKH_PLUS !IN LAYER THICKNESS AK(K+1) - AK(K) VCORIO1D.110
*,DELTA_BKH_PLUS !IN LAYER THICKNESS BK(K+1) - BK(K) VCORIO1D.111
C*--------------------------------------------------------------------- VCORIO1D.112
VCORIO1D.113
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- VCORIO1D.114
C DEFINE LOCAL ARRAYS: 5 ARE REQUIRED VCORIO1D.115
VCORIO1D.116
REAL VCORIO1D.117
* DP_BY_DT(U_FIELD) VCORIO1D.118
*,WP(U_FIELD) VCORIO1D.119
*,WORK1(U_FIELD) VCORIO1D.120
*,WORK2(U_FIELD) VCORIO1D.121
*,TS(U_FIELD) VCORIO1D.122
VCORIO1D.123
C*--------------------------------------------------------------------- VCORIO1D.124
C DEFINE LOCAL VARIABLES VCORIO1D.125
REAL VCORIO1D.126
* SCALAR VCORIO1D.127
VCORIO1D.128
C COUNT VARIABLES FOR DO LOOPS ETC. VCORIO1D.129
INTEGER VCORIO1D.130
* I, POINTS VCORIO1D.131
VCORIO1D.132
C LOGICAL VARIABLES VCORIO1D.133
LOGICAL VCORIO1D.134
* CONSTANT_PRESSURE VCORIO1D.135
*,LLINTS ! Switch for linear TS calc in CALC_TS VCORIO1D.136
VCORIO1D.137
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- VCORIO1D.138
EXTERNAL CALC_TS VCORIO1D.139
C*--------------------------------------------------------------------- VCORIO1D.140
CL CALL COMDECK TO OBTAIN CONSTANTS USED. VCORIO1D.141
VCORIO1D.142
*CALL C_VCORI VCORIO1D.143
VCORIO1D.144
CL MAXIMUM VECTOR LENGTH ASSUMED IS END_U_UPDATE+ROW_LENGTH+1- VCORIO1D.145
CL START_U_UPDATE VCORIO1D.146
CL--------------------------------------------------------------------- VCORIO1D.147
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: VCORIO1D.148
CL--------------------------------------------------------------------- VCORIO1D.149
CL VCORIO1D.150
CL--------------------------------------------------------------------- VCORIO1D.151
CL SECTION 1. CALCULATE DP/DT VCORIO1D.152
CL--------------------------------------------------------------------- VCORIO1D.153
*IF DEF,MPP ATJ0F403.187
!! First update halos of u and v fields since the indexing errors in ATJ0F403.188
!! later calculations are otherwise not using the correct data ATJ0F403.189
CALL SWAPBOUNDS(u,local_row_length,tot_u_rows,ew_halo,ns_halo,1) ATJ0F403.190
CALL SWAPBOUNDS(v,local_row_length,tot_u_rows,ew_halo,ns_halo,1) ATJ0F403.191
*ENDIF ATJ0F403.192
VCORIO1D.154
IF(BK.EQ.0.) THEN VCORIO1D.155
C A CONSTANT PRESSURE LEVEL SO DP/DT IS ZERO. VCORIO1D.156
CONSTANT_PRESSURE = .TRUE. VCORIO1D.157
! Loop over U field missing top and bottom rows and halos VCORIO1D.158
DO 100 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO VCORIO1D.159
DP_BY_DT(I) = 0. VCORIO1D.160
100 CONTINUE VCORIO1D.161
ELSE VCORIO1D.162
C CALCULATE DP/DT. VCORIO1D.163
CONSTANT_PRESSURE = .FALSE. VCORIO1D.164
SCALAR = BK/ADVECTION_TIMESTEP VCORIO1D.165
! Loop over U field missing top and bottom rows and halos VCORIO1D.166
DO 110 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO VCORIO1D.167
DP_BY_DT(I) = (DELTA_AK+DELTA_BK*PSTAR_OLD(I))*RS(I)*RS(I) VCORIO1D.168
* *(PSTAR(I)-PSTAR_OLD(I))*SCALAR VCORIO1D.169
110 CONTINUE VCORIO1D.170
END IF VCORIO1D.171
VCORIO1D.172
CL--------------------------------------------------------------------- VCORIO1D.173
CL SECTION 2. CALCULATE U.GRAD P VCORIO1D.174
CL--------------------------------------------------------------------- VCORIO1D.175
VCORIO1D.176
C---------------------------------------------------------------------- VCORIO1D.177
CL SECTION 2.1 CALCULATE U DP/D(LONGITUDE) VCORIO1D.178
C---------------------------------------------------------------------- VCORIO1D.179
VCORIO1D.180
C CALCULATE U DP/D(LONGITUDE) BETWEEN P POINTS VCORIO1D.181
! Loop over U field missing top and bottom rows and halos and VCORIO1D.182
! last point (includes HADCM2-specific error) VCORIO1D.183
DO 210 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO VCORIO1D.184
WORK1(I) = .5*(U(I)+U(I-ROW_LENGTH))*(PSTAR(I+1)-PSTAR(I))* VCORIO1D.185
* LONGITUDE_STEP_INVERSE*BK VCORIO1D.186
210 CONTINUE VCORIO1D.187
VCORIO1D.188
*IF DEF,GLOBAL VCORIO1D.189
*IF -DEF,MPP VCORIO1D.190
C GLOBAL MODEL SO RECALCULATE VALUE AT END-POINT VCORIO1D.191
! Loop ove the last point of each row missing top and bottom rows VCORIO1D.192
! and halos (includes HADCM2-specific error) VCORIO1D.193
DO 212 I=START_POINT_NO_HALO+LAST_ROW_PT-1, VCORIO1D.194
& END_U_POINT_NO_HALO,ROW_LENGTH VCORIO1D.195
WORK1(I) = .5*(U(I)+U(I-ROW_LENGTH))*(PSTAR(I+1-ROW_LENGTH)- VCORIO1D.196
* PSTAR(I))*LONGITUDE_STEP_INVERSE*BK VCORIO1D.197
212 CONTINUE VCORIO1D.198
*ELSE VCORIO1D.199
WORK1(END_U_POINT_NO_HALO) = 0.0 VCORIO1D.200
! MPP Code : No need to do recalculations of end points because cyclic VCORIO1D.201
! boundary conditions means that halos do this for us automatically VCORIO1D.202
VCORIO1D.203
*ENDIF VCORIO1D.204
*ELSE VCORIO1D.205
WORK1(END_U_POINT_NO_HALO) = 0.0 VCORIO1D.206
*ENDIF VCORIO1D.207
VCORIO1D.208
C CALCULATE U DP/D(LONGITUDE) AT P POINTS VCORIO1D.209
VCORIO1D.210
! Loop over U field missing top and bottom rows and halos and VCORIO1D.211
! first point VCORIO1D.212
DO 214 I=START_POINT_NO_HALO+1,END_U_POINT_NO_HALO VCORIO1D.213
WP(I) = .5*(WORK1(I)+WORK1(I-1)) VCORIO1D.214
214 CONTINUE VCORIO1D.215
VCORIO1D.216
C---------------------------------------------------------------------- VCORIO1D.217
CL SECTION 2.2 CALCULATE V DP/D(LATITUDE) AND HENCE U.GRAD P VCORIO1D.218
C---------------------------------------------------------------------- VCORIO1D.219
VCORIO1D.220
C CALCULATE V DP/D(LATITUDE) BETWEEN P POINTS. VCORIO1D.221
VCORIO1D.222
! Loop over U field missing bottom row, last point and top and VCORIO1D.223
! bottom halos (includes HADCM2-specific error) VCORIO1D.224
DO 220 I=START_POINT_NO_HALO-ROW_LENGTH+1,END_U_POINT_NO_HALO VCORIO1D.225
WORK2(I) = .5*(V(I)+V(I-1))*(PSTAR(I)-PSTAR(I+ROW_LENGTH)) VCORIO1D.226
* *LATITUDE_STEP_INVERSE*BK VCORIO1D.227
220 CONTINUE VCORIO1D.228
VCORIO1D.229
VCORIO1D.231
*IF -DEF,MPP VCORIO1D.232
! Last point of row above START_POINT row VCORIO1D.233
! (includes HADCM2-specific error) VCORIO1D.234
I=START_POINT_NO_HALO-2*ROW_LENGTH+LAST_ROW_PT VCORIO1D.235
C GLOBAL MODEL SO RECALCULATE LAST POINT VALUES FOR V DP/D(LAT) ATJ0F403.193
VCORIO1D.237
WORK2(I) = .5*(V(I)+V(I-1+ROW_LENGTH))*(PSTAR(I)- VCORIO1D.238
* PSTAR(I+ROW_LENGTH))*LATITUDE_STEP_INVERSE*BK VCORIO1D.239
VCORIO1D.240
! Loop over first point of each row, missing top and bottom rows and VCORIO1D.241
! halos (includes HADCM2-specific error) VCORIO1D.242
DO 222 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO,ROW_LENGTH VCORIO1D.243
WORK2(I) = .5*(V(I)+V(I-1+ROW_LENGTH))*(PSTAR(I)- VCORIO1D.244
* PSTAR(I+ROW_LENGTH))*LATITUDE_STEP_INVERSE*BK VCORIO1D.245
VCORIO1D.246
C AND U DP/D(LONG) AT P POINTS. VCORIO1D.247
WP(I) = .5*(WORK1(I)+WORK1(I-1+ROW_LENGTH)) VCORIO1D.248
222 CONTINUE VCORIO1D.249
*ELSE VCORIO1D.250
WORK2(END_U_POINT_NO_HALO)=WORK2(END_U_POINT_NO_HALO-1) VCORIO1D.251
WP(START_POINT_NO_HALO)=WP(START_POINT_NO_HALO+1) VCORIO1D.252
! MPP Code : No need to do recalculations of end points because cyclic VCORIO1D.253
! boundary conditions means that halos do this for us automatically VCORIO1D.254
VCORIO1D.255
*ENDIF VCORIO1D.256
VCORIO1D.257
VCORIO1D.259
C CALCULATE U.GRAD P VCORIO1D.260
VCORIO1D.261
*IF DEF,GLOBAL,OR,DEF,MPP ATJ0F403.194
! Loop over field, missing top and bottom rows and halos VCORIO1D.263
DO 224 I=START_POINT_NO_HALO+1,END_U_POINT_NO_HALO VCORIO1D.264
*ELSE VCORIO1D.265
! Loop over field, missing top and bottom rows and halos, and first VCORIO1D.266
! and last points. VCORIO1D.267
DO 224 I=START_POINT_NO_HALO+1,END_U_POINT_NO_HALO-1 VCORIO1D.268
*ENDIF VCORIO1D.269
WP(I)=(WP(I)+.5*(WORK2(I)+WORK2(I-ROW_LENGTH))) VCORIO1D.270
* *SEC_U_LATITUDE(I) VCORIO1D.271
224 CONTINUE VCORIO1D.272
VCORIO1D.273
CL--------------------------------------------------------------------- VCORIO1D.274
CL SECTION 3. CALL CALC_TS TO GET TS. VCORIO1D.275
CL--------------------------------------------------------------------- VCORIO1D.276
VCORIO1D.277
C STORE PRESSURE IN WORK. VCORIO1D.278
! Loop over field, missing top and bottom rows and halos VCORIO1D.279
DO 300 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO VCORIO1D.280
WORK2(I) = AK + BK*PSTAR(I) VCORIO1D.281
300 CONTINUE VCORIO1D.282
VCORIO1D.283
C CALCULATE NUMBER OF POINTS CALC_TS TO BE CALLED FOR. VCORIO1D.284
POINTS = END_U_POINT_NO_HALO-START_POINT_NO_HALO+1 VCORIO1D.285
VCORIO1D.286
C TS IS RETURNED IN WORK. VCORIO1D.287
VCORIO1D.288
CALL CALC_TS(WORK2(START_POINT_NO_HALO),TS(START_POINT_NO_HALO), VCORIO1D.289
& POINTS,CONSTANT_PRESSURE,LLINTS) VCORIO1D.290
VCORIO1D.291
CL--------------------------------------------------------------------- VCORIO1D.292
CL SECTION 4. CALCULATE WK AS IN EQUATION (43). VCORIO1D.293
CL--------------------------------------------------------------------- VCORIO1D.294
VCORIO1D.295
*IF DEF,GLOBAL,OR,DEF,MPP ATJ0F403.195
! Loop over field, missing top and bottom rows and halos VCORIO1D.297
DO 400 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO VCORIO1D.298
*ELSE VCORIO1D.299
DO 400 I=START_POINT_NO_HALO+1,END_U_POINT_NO_HALO-1 VCORIO1D.300
*ENDIF VCORIO1D.301
OMEGA(I)= WP(I)+DP_BY_DT(I)+.5*(ETADOT_PLUS(I)* VCORIO1D.302
* (DELTA_AKH_PLUS+DELTA_BKH_PLUS*PSTAR(I))+ETADOT_MINUS(I) VCORIO1D.303
* *(DELTA_AKH_MINUS+DELTA_BKH_MINUS*PSTAR(I))) VCORIO1D.304
WK(I) = -R*TS(I)*OMEGA(I)/(G*WORK2(I)) VCORIO1D.305
400 CONTINUE VCORIO1D.306
VCORIO1D.307
*IF -DEF,GLOBAL VCORIO1D.308
VCORIO1D.309
CL LIMITED AREA MODEL SET VERTICAL VELOCITY ON BOUNDARY TO ZERO. VCORIO1D.310
VCORIO1D.311
*IF DEF,MPP VCORIO1D.312
IF (at_left_of_LPG) THEN VCORIO1D.313
*ENDIF VCORIO1D.314
! Set first point of each row to zero VCORIO1D.315
DO I=START_POINT_NO_HALO+FIRST_ROW_PT-1,END_U_POINT_NO_HALO, VCORIO1D.316
& ROW_LENGTH VCORIO1D.317
WK(I)=0.0 VCORIO1D.318
OMEGA(I)=0.0 VCORIO1D.319
*IF -DEF,GLOBAL ATJ0F403.196
WK(I-1)=0.0 ATJ0F403.197
OMEGA(I-1)=0.0 ATJ0F403.198
*ENDIF ATJ0F403.199
ENDDO VCORIO1D.320
*IF DEF,MPP VCORIO1D.321
ENDIF VCORIO1D.322
VCORIO1D.323
IF (at_right_of_LPG) THEN VCORIO1D.324
*ENDIF VCORIO1D.325
! Set last two points of each row to zero VCORIO1D.326
DO I=START_POINT_NO_HALO+LAST_ROW_PT-2,END_U_POINT_NO_HALO, VCORIO1D.327
& ROW_LENGTH VCORIO1D.328
WK(I)=0.0 VCORIO1D.329
WK(I+1)=0.0 VCORIO1D.330
OMEGA(I)=0.0 VCORIO1D.331
OMEGA(I+1)=0.0 VCORIO1D.332
*IF -DEF,GLOBAL ATJ0F403.200
WK(I+2)=0.0 ATJ0F403.201
OMEGA(I+2)=0.0 ATJ0F403.202
*ENDIF ATJ0F403.203
ENDDO VCORIO1D.333
*IF DEF,MPP VCORIO1D.334
ENDIF VCORIO1D.335
*ENDIF VCORIO1D.336
VCORIO1D.337
*ENDIF VCORIO1D.338
VCORIO1D.339
CL END OF ROUTINE V_CORIOL VCORIO1D.340
VCORIO1D.341
RETURN VCORIO1D.342
END VCORIO1D.343
VCORIO1D.344
*ENDIF VCORIO1D.345