*IF DEF,A07_1B VERTDF1B.2
C ******************************COPYRIGHT****************************** VERTDF1B.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. VERTDF1B.4
C VERTDF1B.5
C Use, duplication or disclosure of this code is subject to the VERTDF1B.6
C restrictions as set forth in the contract. VERTDF1B.7
C VERTDF1B.8
C Meteorological Office VERTDF1B.9
C London Road VERTDF1B.10
C BRACKNELL VERTDF1B.11
C Berkshire UK VERTDF1B.12
C RG12 2SZ VERTDF1B.13
C VERTDF1B.14
C If no contract has been raised with this copy of the code, the use, VERTDF1B.15
C duplication or disclosure of it is strictly prohibited. Permission VERTDF1B.16
C to do so must first be obtained in writing from the Head of Numerical VERTDF1B.17
C Modelling at the above address. VERTDF1B.18
C ******************************COPYRIGHT****************************** VERTDF1B.19
C VERTDF1B.20
CLL SUBROUTINE VDIF_CTL and VERT_DIF -------------------------- VERTDF1B.21
CLL VERTDF1B.22
CLL PURPOSE: CONTROL SECTION FOR VERTICAL DIFFUSION ROUTINE WHICH VERTDF1B.23
CLL APPLIES VERTICAL DIFFUSION TO WIND COMPONENTS WITHIN A LATITUDE BAND VERTDF1B.24
CLL SYMMETRIC ABOUT THE EQUATOR. THE DIFFUSION COEFFICIENT TAILS OFF VERTDF1B.25
CLL AWAY FROM THE EQUATOR AND IS ZERO OUTSIDE THE BAND. VERTDF1B.26
CLL VERTDF1B.27
CLL FURTHER ALTERATIONS MAY BE REQUIRED FOR AUTOTASKING EFFICIENCY VERTDF1B.28
CLL SUITABLE FOR SINGLE COLUMN USE, CALL TO P_TO_UV BY-PASSED VERTDF1B.29
CLL SUITABLE FOR ROTATED GRIDS VERTDF1B.30
CLL VERTDF1B.31
CLL ORIGINAL VERSION FOR CRAY Y-MP VERTDF1B.32
CLL VERTDF1B.33
CLL WRITTEN BY C. WILSON VERTDF1B.34
CLL VERTDF1B.35
CLL Model Modification history: VERTDF1B.36
CLL version Date VERTDF1B.37
CLL VERTDF1B.38
!LL 4.4 11/08/97 New version optimised for T3E. VERTDF1B.39
!LL Not bit-reproducible with VERTDF1A. VERTDF1B.40
CLL 4.4 14/07/97 Gather to diffusion points removed, since it VERTDF1B.41
CLL it becomes an overhead on T3E for equatorial VERTDF1B.42
CLL PEs. VERTDF1B.43
CLL A. Dickinson VERTDF1B.44
CLL 4.5 Jul. 98 Kill the IBM specific lines (JCThil) AJC1F405.36
CLL VERTDF1B.45
CLL Programming standard: VERTDF1B.46
CLL VERTDF1B.47
CLL Logical components covered: P21 VERTDF1B.48
CLL VERTDF1B.49
CLL Project task: VERTDF1B.50
CLL VERTDF1B.51
CLL Documentation: The equation used is (2) VERTDF1B.52
CLL in Unified Model documentation paper no.p21 VERTDF1B.53
CLL C. Wilson, version 2,dated 30/10/89 VERTDF1B.54
CLLEND------------------------------------------------------------- VERTDF1B.55
C VERTDF1B.56
C*L ARGUMENTS:--------------------------------------------------- VERTDF1B.57
SUBROUTINE VDIF_CTL 1,4VERTDF1B.58
* (PSTAR,U,V, VERTDF1B.59
* P_FIELD,U_FIELD,ROWS,FIRST_ROW,ROW_LENGTH, VERTDF1B.60
* LEVEL_START,LEVEL_END,LEVELS_VD,P_LEVELS, VERTDF1B.61
* AK,BK,DELTA_AK,DELTA_BK,COS_LAT, LATITUDE_BAND, VERTDF1B.62
* VERTICAL_DIFFUSION, TIMESTEP, VERTDF1B.63
* STASH_U_FLUX,FLUX_UD_ON,U_LIST, VERTDF1B.64
* STASH_V_FLUX,FLUX_VD_ON,V_LIST, VERTDF1B.65
* LEN_STASH_U_FLUX,LEN_STASH_V_FLUX, VERTDF1B.66
* POINTS_FLUX_U,POINTS_FLUX_V,LEVELS_FLUX, VERTDF1B.67
* IRET) VERTDF1B.68
VERTDF1B.69
IMPLICIT NONE VERTDF1B.70
VERTDF1B.71
INTEGER VERTDF1B.72
* P_FIELD !IN 1ST DIMENSION OF FIELD OF PSTAR VERTDF1B.73
*, U_FIELD !IN 1ST DIMENSION OF FIELD OF U,V VERTDF1B.74
*, ROWS !IN NUMBER OF ROWS TO BE UPDATED. VERTDF1B.75
*, FIRST_ROW !IN NUMBER OF FIRST ROW IN DATA ARRAY VERTDF1B.76
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW VERTDF1B.77
*, LEVEL_START !IN BOTTOM LEVEL TO BE UPDATED. VERTDF1B.78
*, LEVEL_END !IN TOP LEVEL TO BE UPDATED. VERTDF1B.79
*, LEVELS_VD !IN NO OF VERTICAL DIFFUSION LEVELS VERTDF1B.80
*, P_LEVELS !IN NUMBER OF MODEL LEVELS VERTDF1B.81
*, LEN_STASH_U_FLUX !IN DIMENSION OF STASH_U_FLUX VERTDF1B.82
*, LEN_STASH_V_FLUX !IN DIMENSION OF STASH_V_FLUX VERTDF1B.83
*, POINTS_FLUX_U !IN NO OF POINTS IN U FLUX FIELD VERTDF1B.84
*, POINTS_FLUX_V !IN NO OF POINTS IN V FLUX FIELD VERTDF1B.85
*, LEVELS_FLUX !IN NO OF FLUX LEVELS VERTDF1B.86
*, IRET ! RETURN CODE : IRET=0 NORMAL EXIT VERTDF1B.87
VERTDF1B.88
REAL VERTDF1B.89
* PSTAR(P_FIELD) !IN PRIMARY MODEL ARRAY FOR PSTAR FIELD VERTDF1B.90
*,U(U_FIELD,P_LEVELS) !INOUT PRIMARY MODEL ARRAY FOR U FIELD VERTDF1B.91
*,V(U_FIELD,P_LEVELS) !INOUT PRIMARY MODEL ARRAY FOR V FIELD VERTDF1B.92
C AK,BK DEFINE HYBRID VERTICAL COORDINATES P=A+BP*, VERTDF1B.93
C DELTA_AK,DELTA_BK DEFINE LAYER PRESSURE THICKNESS PD=AD+BDP*, VERTDF1B.94
*,DELTA_AK(P_LEVELS) !IN LAYER THICKNESS VERTDF1B.95
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS VERTDF1B.96
*,AK (P_LEVELS) !IN VALUE AT LAYER CENTRE VERTDF1B.97
*,BK (P_LEVELS) !IN VALUE AT LAYER CENTRE VERTDF1B.98
*,COS_LAT(U_FIELD) !IN COS(LAT) AT U POINTS VERTDF1B.99
*,LATITUDE_BAND !IN LATITUDE(RADIANS) VERTDF1B.100
* ! WHERE DIFFUSION PRESCRIBED ZERO VERTDF1B.101
*,VERTICAL_DIFFUSION !IN VALUE OF DIFFUSION COEFFICIENT VERTDF1B.102
*,TIMESTEP !IN TIMESTEP VERTDF1B.103
*,STASH_U_FLUX(LEN_STASH_U_FLUX,*) !U MOMENTUM FLUX - Diagnostic VERTDF1B.104
*,STASH_V_FLUX(LEN_STASH_V_FLUX,*) !V MOMENTUM FLUX - Diagnostic VERTDF1B.105
VERTDF1B.106
C WARNING : Storage is only assigned by the controling routine VERTDF1B.107
C for the number of levels requested. VERTDF1B.108
VERTDF1B.109
LOGICAL VERTDF1B.110
* FLUX_UD_ON !U momentum diagnostic switch VERTDF1B.111
*,FLUX_VD_ON !V momentum diagnostic switch VERTDF1B.112
*,U_LIST(P_LEVELS) ! List of levels required VERTDF1B.113
*,V_LIST(P_LEVELS) ! List of levels required VERTDF1B.114
VERTDF1B.115
C*--------------------------------------------------------------------- VERTDF1B.116
VERTDF1B.117
*IF DEF,MPP VERTDF1B.118
! Parameters and Common blocks VERTDF1B.119
*CALL PARVARS 
VERTDF1B.120
*ENDIF VERTDF1B.121
C*L WORKSPACE USAGE:------------------------------------------------- VERTDF1B.122
C DEFINE LOCAL WORKSPACE ARRAYS: 4+(LEVEL_END-LEVEL_START+1)*2 VERTDF1B.123
VERTDF1B.124
C +(LEVEL_END-LEVEL_START)*2 VERTDF1B.125
VERTDF1B.126
C REAL ARRAYS REQUIRED AT FULL FIELD LENGTH VERTDF1B.127
C 1 INTEGER INDEX ARRAY VERTDF1B.128
VERTDF1B.129
REAL VERTDF1B.138
* PSTAR_UV( ROWS*ROW_LENGTH ) ! INTERPOLATED PSTAR ON UV-GRID VERTDF1B.139
*,VERT_DIF_LAT(ROWS*ROW_LENGTH) ! LAT. DEPENDENT DIFFUSION*TIMESTEP VERTDF1B.140
*,FLUX_U_DG(POINTS_FLUX_U,LEVELS_FLUX) !FLUX VERTDF1B.141
*,FLUX_V_DG(POINTS_FLUX_V,LEVELS_FLUX) !FLUX VERTDF1B.142
VERTDF1B.143
VERTDF1B.144
VERTDF1B.146
C*--------------------------------------------------------------------- VERTDF1B.147
C VERTDF1B.148
C*L EXTERNAL SUBROUTINES CALLED--------------------------------------- VERTDF1B.149
EXTERNAL P_TO_UV ,VERT_DIF,TIMER VERTDF1B.150
C*------------------------------------------------------------------ VERTDF1B.151
CL MAXIMUM VECTOR LENGTH ASSUMED IS (ROWS+1) * ROWLENGTH VERTDF1B.152
CL--------------------------------------------------------------------- VERTDF1B.153
C---------------------------------------------------------------------- VERTDF1B.154
C DEFINE LOCAL VARIABLES VERTDF1B.155
INTEGER VERTDF1B.156
* P_POINTS ! NUMBER OF P POINTS NEEDED VERTDF1B.157
*, ROWS_P ! NUMBER OF P ROWS NEEDED VERTDF1B.158
*, U_POINTS ! NUMBER OF U POINTS UPDATED VERTDF1B.159
*, START_P ! START POSITION FOR P POINTS NEEDED VERTDF1B.160
*, START_U ! START POSITION FOR U POINTS UPDATED VERTDF1B.161
*, POINTS_VD ! NUMBER OF POINTS NON-ZERO DIFFUSION COEFFS VERTDF1B.162
VERTDF1B.163
REAL VERTDF1B.164
* COS_LAT_BAND ! COS LAT AT WHICH DIFFUSION SET TO ZERO VERTDF1B.165
*, COEFF ! LATITUDE-DEPENDENT DIFFUSION * TIMESTEP VERTDF1B.166
C VERTDF1B.167
INTEGER K,I,II,IK,! LOOP COUNTERS IN ROUTINE VERTDF1B.168
* KOUT_U,KOUT_V VERTDF1B.169
C VERTDF1B.170
VERTDF1B.171
C------------------------------------------------------------------- VERTDF1B.172
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: VERTDF1B.173
CL 1. INITIALISATION VERTDF1B.174
C-------------------------- VERTDF1B.175
VERTDF1B.176
START_P = (FIRST_ROW-1)*ROW_LENGTH VERTDF1B.177
START_U = START_P VERTDF1B.178
*IF -DEF,MPP VERTDF1B.179
ROWS_P = ROWS+1 VERTDF1B.180
*ELSE VERTDF1B.181
IF (atbase) THEN VERTDF1B.182
ROWS_P=ROWS VERTDF1B.183
ELSE VERTDF1B.184
ROWS_P=ROWS+1 VERTDF1B.185
ENDIF VERTDF1B.186
*ENDIF VERTDF1B.187
P_POINTS = (ROWS_P)*ROW_LENGTH VERTDF1B.188
*IF -DEF,MPP VERTDF1B.189
U_POINTS = ROWS*ROW_LENGTH VERTDF1B.190
*ELSE VERTDF1B.191
IF (atbase) THEN VERTDF1B.192
U_POINTS=(ROWS-1)*ROW_LENGTH VERTDF1B.193
ELSE VERTDF1B.194
U_POINTS=ROWS*ROW_LENGTH VERTDF1B.195
ENDIF VERTDF1B.196
*ENDIF VERTDF1B.197
VERTDF1B.198
C------------------------------------------------------------------ VERTDF1B.199
CL 1.1 CALCULATE LATITUDE-DEPENDENT DIFFUSION COEFFICIENTS*TIMESTEP VERTDF1B.200
CL AND SET TO ZERO WHERE NO DIFFUSION REQUIRED VERTDF1B.201
C------------------------------------------------------------------ VERTDF1B.202
VERTDF1B.203
COS_LAT_BAND = COS(LATITUDE_BAND) VERTDF1B.204
COEFF = VERTICAL_DIFFUSION * TIMESTEP / (1.- COS_LAT_BAND) VERTDF1B.205
C VERTDF1B.206
DO I=1,U_POINTS VERTDF1B.207
VERT_DIF_LAT(I) = COEFF * ( COS_LAT(START_U+I) - COS_LAT_BAND) VERTDF1B.208
IF(VERT_DIF_LAT(I).LT.0.0)VERT_DIF_LAT(I)=0.0 VERTDF1B.209
END DO VERTDF1B.210
VERTDF1B.211
C------------------------------------------------------------------ VERTDF1B.212
CL 1.2 INTERPOLATE PSTAR TO UV GRID VERTDF1B.213
C------------------------------------------------------------------ VERTDF1B.214
VERTDF1B.215
*IF DEF,SCMA AJC1F405.37
VERTDF1B.217
DO I=1,U_POINTS VERTDF1B.218
PSTAR_UV(I) =PSTAR(I) VERTDF1B.219
END DO VERTDF1B.220
VERTDF1B.221
*ELSE VERTDF1B.222
VERTDF1B.223
CALL P_TO_UV(PSTAR(START_P+1),PSTAR_UV,P_POINTS,U_POINTS, VERTDF1B.224
* ROW_LENGTH,ROWS_P) VERTDF1B.225
VERTDF1B.226
*ENDIF VERTDF1B.227
VERTDF1B.228
VERTDF1B.229
LEVELS_VD=LEVEL_END-LEVEL_START+1 VERTDF1B.230
VERTDF1B.231
C------------------------------------------------------------------ VERTDF1B.232
CL 2. CALL VERT_DIF AND UPDATE WINDS VERTDF1B.233
C------------------------------------------------------------------ VERTDF1B.234
VERTDF1B.235
CALL VERT_DIF(PSTAR_UV, VERTDF1B.236
& U(START_U+1,LEVEL_START),V(START_U+1,LEVEL_START), VERTDF1B.237
& LEVELS_VD,U_POINTS,U_FIELD, VERTDF1B.238
& AK(LEVEL_START),BK(LEVEL_START), VERTDF1B.239
& DELTA_AK(LEVEL_START),DELTA_BK(LEVEL_START), VERTDF1B.240
& VERT_DIF_LAT,FLUX_U_DG,FLUX_V_DG, VERTDF1B.241
& POINTS_FLUX_U,POINTS_FLUX_V,LEVELS_FLUX, VERTDF1B.242
& FLUX_UD_ON,FLUX_VD_ON) VERTDF1B.243
VERTDF1B.244
VERTDF1B.245
IF (FLUX_UD_ON .OR. FLUX_VD_ON) THEN VERTDF1B.246
VERTDF1B.247
KOUT_U=0 VERTDF1B.248
KOUT_V=0 VERTDF1B.249
VERTDF1B.250
DO K = LEVEL_START,LEVEL_END-1 VERTDF1B.251
VERTDF1B.252
IF (U_LIST(K)) THEN VERTDF1B.253
KOUT_U=KOUT_U+1 VERTDF1B.254
END IF VERTDF1B.255
IF (V_LIST(K)) THEN VERTDF1B.256
KOUT_V=KOUT_V+1 VERTDF1B.257
END IF VERTDF1B.258
VERTDF1B.259
IK = K-LEVEL_START+1 VERTDF1B.260
VERTDF1B.261
DO I=1,U_POINTS VERTDF1B.262
VERTDF1B.263
IF (FLUX_UD_ON .AND. U_LIST(K)) THEN VERTDF1B.264
STASH_U_FLUX(START_U+I,KOUT_U) = FLUX_U_DG(I,IK) VERTDF1B.265
ENDIF VERTDF1B.266
IF (FLUX_VD_ON .AND. V_LIST(K)) THEN VERTDF1B.267
STASH_V_FLUX(START_U+I,KOUT_V) = FLUX_V_DG(I,IK) VERTDF1B.268
ENDIF VERTDF1B.269
VERTDF1B.270
ENDDO VERTDF1B.271
VERTDF1B.272
ENDDO VERTDF1B.273
VERTDF1B.274
ENDIF VERTDF1B.275
VERTDF1B.276
IRET=0 VERTDF1B.277
VERTDF1B.278
1000 CONTINUE VERTDF1B.279
RETURN VERTDF1B.280
END VERTDF1B.281
CLL SUBROUTINE VERT_DIF-------------------------------------------- VERTDF1B.282
CLL VERTDF1B.283
CLL PURPOSE: TO APPLY VERTICAL DIFFUSION TO WIND COMPONENTS VERTDF1B.284
CLL WITHIN A LATITUDE BAND SYMMETRIC ABOUT THE EQUATOR. VERTDF1B.285
CLL THE DIFFUSION COEFFICIENT TAILS OFF AWAY FROM THE VERTDF1B.286
CLL EQUATOR AND IS ZERO OUTSIDE THE BAND. VERTDF1B.287
CLL THIS ROUTINE APPLIES A PRECALCULATED VERTDF1B.288
CLL DIFFUSION COEFFICIENT TO ALL POINTS PASSED TO IT VERTDF1B.289
CLL SUITABLE FOR SINGLE COLUMN USE VERTDF1B.290
CLL SUITABLE FOR ROTATED GRIDS VERTDF1B.291
CLL FURTHER ALTERATIONS MAY BE REQUIRED FOR AUTOTASKING EFFICIENCY VERTDF1B.292
CLL ORIGINAL VERSION FOR CRAY Y-MP VERTDF1B.293
CLL VERTDF1B.294
CLL WRITTEN BY C. WILSON VERTDF1B.295
CLL VERTDF1B.296
CLL Model Modification history: VERTDF1B.297
CLL version Date VERTDF1B.298
CLL 4.5 Jul. 98 Kill the IBM specific lines (JCThil) AJC1F405.38
CLL VERTDF1B.299
CLL PROGRAMMING STANDARD: VERTDF1B.300
CLL VERTDF1B.301
CLL LOGICAL COMPONENTS COVERED: P21 VERTDF1B.302
CLL VERTDF1B.303
CLL PROJECT TASK: VERTDF1B.304
CLL VERTDF1B.305
CLL DOCUMENTATION: THE EQUATIONS USED ARE (1) TO (4) VERTDF1B.306
CLL IN UNIFIED MODEL DOCUMENTATION PAPER NO.P21 VERTDF1B.307
CLL C. WILSON, VERSION 2,DATED 30/10/89 VERTDF1B.308
CLLEND------------------------------------------------------------- VERTDF1B.309
VERTDF1B.310
C VERTDF1B.311
C*L ARGUMENTS:--------------------------------------------------- VERTDF1B.312
SUBROUTINE VERT_DIF 2VERTDF1B.313
* (PSTAR,U,V,LEVELS_VD,POINTS_VD,UFIELD,AK,BK,DELTA_AK,DELTA_BK, VERTDF1B.314
* DIFFUSION_K,FLUX_U_DG,FLUX_V_DG,POINTS_FLUX_U,POINTS_FLUX_V, VERTDF1B.315
* LEVELS_FLUX,FLUX_UD_ON,FLUX_VD_ON) VERTDF1B.316
VERTDF1B.317
IMPLICIT NONE VERTDF1B.318
VERTDF1B.319
INTEGER VERTDF1B.320
* POINTS_VD !IN NUMBER OF POINTS TO BE UPDATED VERTDF1B.321
*, LEVELS_VD !IN NUMBER OF LEVELS TO BE UPDATED VERTDF1B.322
*, UFIELD !IN DIMENSION OF HORIZ FIELD VERTDF1B.323
*, POINTS_FLUX_U !IN NUMBER OF LEVELS TO BE UPDATED VERTDF1B.324
*, POINTS_FLUX_V !IN NUMBER OF LEVELS TO BE UPDATED VERTDF1B.325
*, LEVELS_FLUX !IN NUMBER OF LEVELS TO BE UPDATED VERTDF1B.326
VERTDF1B.327
REAL VERTDF1B.328
* PSTAR(UFIELD) !IN PSTAR FIELD VERTDF1B.329
*,U(UFIELD,LEVELS_VD) !INOUT ARRAY FOR U FIELD VERTDF1B.330
*,V(UFIELD,LEVELS_VD) !INOUT ARRAY FOR V FIELD VERTDF1B.331
C AK,BK DEFINE HYBRID VERTICAL COORDINATES P=A+BP*, VERTDF1B.332
C DELTA_AK,DELTA_BK DEFINE LAYER PRESSURE THICKNESS PD=AD+BDP*, VERTDF1B.333
*,DELTA_AK(LEVELS_VD) !IN LAYER THICKNESS VERTDF1B.334
*,DELTA_BK(LEVELS_VD) !IN LAYER THICKNESS VERTDF1B.335
*,AK (LEVELS_VD) !IN VALUE AT LAYER CENTRE VERTDF1B.336
*,BK (LEVELS_VD) !IN VALUE AT LAYER CENTRE VERTDF1B.337
*,DIFFUSION_K(UFIELD) ! LAT. DEPENDENT DIFFUSION*TIMESTEP VERTDF1B.338
*,FLUX_U_DG(POINTS_FLUX_U,LEVELS_FLUX) ! U MOMENTUM FLUX VERTDF1B.339
* ! DIAGNOSTIC VERTDF1B.340
*,FLUX_V_DG(POINTS_FLUX_V,LEVELS_FLUX) ! V MOMENTUM FLUX VERTDF1B.341
* ! DIAGNOSTIC VERTDF1B.342
LOGICAL VERTDF1B.343
* FLUX_UD_ON !U momentum diagnostic switch VERTDF1B.344
*,FLUX_VD_ON !V momentum diagnostic switch VERTDF1B.345
VERTDF1B.346
C*--------------------------------------------------------------------- VERTDF1B.347
VERTDF1B.348
C*L WORKSPACE USAGE:------------------------------------------------- VERTDF1B.349
C DEFINE LOCAL WORKSPACE ARRAYS: 4 REAL ARRAYS REQUIRED VERTDF1B.350
C AT FULL FIELD LENGTH (=POINTS) VERTDF1B.351
C VERTDF1B.352
REAL VERTDF1B.359
* FLUX_U(POINTS_VD,2) ! DOWNWARD FLUXES U-MOMENTUM VERTDF1B.360
*,FLUX_V(POINTS_VD,2) ! DOWNWARD FLUXES V-MOMENTUM VERTDF1B.361
VERTDF1B.362
VERTDF1B.364
C*--------------------------------------------------------------------- VERTDF1B.365
C VERTDF1B.366
C*L EXTERNAL SUBROUTINES CALLED--------------------------------------- VERTDF1B.367
C NONE VERTDF1B.368
C*------------------------------------------------------------------ VERTDF1B.369
CL MAXIMUM VECTOR LENGTH ASSUMED =POINTS VERTDF1B.370
CL--------------------------------------------------------------------- VERTDF1B.371
C---------------------------------------------------------------------- VERTDF1B.372
C DEFINE LOCAL VARIABLES VERTDF1B.373
REAL VERTDF1B.374
* DEL_AK ! DIFFERENCE OF AK ACROSS FULL-LEVELS VERTDF1B.375
*, DEL_BK ! DIFFERENCE OF BK ACROSS FULL-LEVELS VERTDF1B.376
*,DELTA_P ! P(K+1/2) - P(K-1/2) VERTDF1B.377
*,DELTA_PL ! P(K+1) - P(K) VERTDF1B.378
C VERTDF1B.379
INTEGER K,I ! LOOP COUNTERS IN ROUTINE VERTDF1B.380
INTEGER KL,KU,KK ! LEVEL COUNTERS IN ROUTINE VERTDF1B.381
C VERTDF1B.382
VERTDF1B.383
C------------------------------------------------------------------- VERTDF1B.384
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: VERTDF1B.385
C------------------------------------------------------------------ VERTDF1B.386
CL 1. CALCULATE VERTICAL FLUX OF MOMENTUM , EQN(1) DOCUMENTATION VERTDF1B.387
CL AND UPDATE U,V VERTDF1B.388
C------------------------------------------------------------------ VERTDF1B.389
VERTDF1B.390
KL = 1 VERTDF1B.391
KU = 2 VERTDF1B.392
DO I=1,POINTS_VD VERTDF1B.393
FLUX_U(I,KL) = 0.0 VERTDF1B.394
FLUX_V(I,KL) = 0.0 VERTDF1B.395
END DO VERTDF1B.396
VERTDF1B.397
CL LOOP OVER LEVELS VERTDF1B.398
VERTDF1B.399
DO K = 1,LEVELS_VD-1 VERTDF1B.400
VERTDF1B.401
CL 1.1 CALCULATE DELTA_P(K) AND DELTA_PL(K) VERTDF1B.402
DEL_AK=AK(K+1) - AK(K) VERTDF1B.403
DEL_BK=BK(K+1) - BK(K) VERTDF1B.404
VERTDF1B.405
DO I=1,POINTS_VD VERTDF1B.406
DELTA_P=DELTA_AK(K)+DELTA_BK(K)*PSTAR(I) VERTDF1B.407
DELTA_PL=DEL_AK+DEL_BK*PSTAR(I) VERTDF1B.408
VERTDF1B.409
CL 1.2 COMPUTE FLUX (+VE UP) AND INCREMENT VERTDF1B.410
VERTDF1B.411
FLUX_U(I,KU)=(U(I,K+1) - U(I,K))*DIFFUSION_K(I)/DELTA_PL VERTDF1B.412
FLUX_V(I,KU)=(V(I,K+1) - V(I,K))*DIFFUSION_K(I)/DELTA_PL VERTDF1B.413
VERTDF1B.414
U(I,K) = U(I,K) + (FLUX_U(I,KU) - FLUX_U(I,KL))/DELTA_P VERTDF1B.415
V(I,K) = V(I,K) + (FLUX_V(I,KU) - FLUX_V(I,KL))/DELTA_P VERTDF1B.416
VERTDF1B.417
END DO VERTDF1B.418
VERTDF1B.419
IF (FLUX_UD_ON) THEN ! SF(201,7) VERTDF1B.420
DO I=1,POINTS_VD VERTDF1B.421
FLUX_U_DG(I,K)= FLUX_U(I,KU) VERTDF1B.422
ENDDO VERTDF1B.423
ENDIF VERTDF1B.424
IF (FLUX_VD_ON) THEN ! SF(202,7) VERTDF1B.425
DO I=1,POINTS_VD VERTDF1B.426
FLUX_V_DG(I,K)= FLUX_V(I,KU) VERTDF1B.427
ENDDO VERTDF1B.428
ENDIF VERTDF1B.429
VERTDF1B.430
C SWAP STORAGE LOCATIONS FOR LOWER AND UPPER FLUXES VERTDF1B.431
KK = KL VERTDF1B.432
KL = KU VERTDF1B.433
KU = KK VERTDF1B.434
VERTDF1B.435
END DO VERTDF1B.436
CL END LOOP OVER LEVELS VERTDF1B.437
VERTDF1B.438
CL LAST LEVEL VERTDF1B.439
K=LEVELS_VD VERTDF1B.440
DO I=1,POINTS_VD VERTDF1B.441
DELTA_P=DELTA_AK(K)+DELTA_BK(K)*PSTAR(I) VERTDF1B.442
U(I,K) = U(I,K) - FLUX_U(I,KL)/DELTA_P VERTDF1B.443
V(I,K) = V(I,K) - FLUX_V(I,KL)/DELTA_P VERTDF1B.444
END DO VERTDF1B.445
VERTDF1B.446
RETURN VERTDF1B.447
END VERTDF1B.448
*ENDIF VERTDF1B.449