*IF DEF,A13_1A,OR,DEF,A13_1B ATJ0F402.29
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.14912
C GTS2F400.14913
C Use, duplication or disclosure of this code is subject to the GTS2F400.14914
C restrictions as set forth in the contract. GTS2F400.14915
C GTS2F400.14916
C Meteorological Office GTS2F400.14917
C London Road GTS2F400.14918
C BRACKNELL GTS2F400.14919
C Berkshire UK GTS2F400.14920
C RG12 2SZ GTS2F400.14921
C GTS2F400.14922
C If no contract has been raised with this copy of the code, the use, GTS2F400.14923
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.14924
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.14925
C Modelling at the above address. GTS2F400.14926
C ******************************COPYRIGHT****************************** GTS2F400.14927
C GTS2F400.14928
CLL SUBROUTINE COEFF_UV ----------------------------------------- COFUV1A.3
CLL COFUV1A.4
CLL PURPOSE: CALCULATES EFFECTIVE DIFFUSIVE COEFFICIENTS FOR U AND V COFUV1A.5
CLL IN NS AND EW DIRECTIONS COFUV1A.6
CLL IF STEEP SLOPE THEN EFFECTIVE DIFFUSION IS ZERO. COFUV1A.7
CLL COFUV1A.8
CLL NOTE PRESSURE ARRAY NEEDS TO BE GLOBAL (SHARED) COFUV1A.9
CLL FOR MULTI-TASKING AT 3.4 UPWARDS. COFUV1A.10
CLL NOT SUITABLE FOR SINGLE COLUMN USE. COFUV1A.11
CLL VERSION FOR CRAY Y-MP COFUV1A.12
CLL COFUV1A.13
CLL MODEL MODIFICATION HISTORY COFUV1A.14
CLL VERSION DATE COFUV1A.15
CLL 4.0 17/01/95 Original code. T.Davies. COFUV1A.16
! 4.1 07/05/96 Added MPP code and TYPFLDPT arguments and fixed APB0F401.1383
! bug in wrap-arounds P.Burton APB0F401.1384
CLL COFUV1A.17
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, COFUV1A.18
CLL STANDARD B. VERSION 2, DATED 18/01/90 COFUV1A.19
CLL COFUV1A.20
CLL SYSTEM COMPONENTS COVERED: P132 COFUV1A.21
CLL COFUV1A.22
CLL SYSTEM TASK: P1 COFUV1A.23
CLL COFUV1A.24
CLL DOCUMENTATION: THE EQUATION USED IS (47) COFUV1A.25
CLL IN UNIFIED MODEL DOCUMENTATION PAPER COFUV1A.26
CLL NO. 10 M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON COFUV1A.27
CLL VERSION 16 DATED 09/01/91. COFUV1A.28
CLLEND------------------------------------------------------------- COFUV1A.29
COFUV1A.30
C*L ARGUMENTS:--------------------------------------------------- COFUV1A.31
SUBROUTINE COEFF_UV 2,2COFUV1A.32
1 (DIFFUSION_EW,DIFFUSION_NS, COFUV1A.33
2 PRESSURE,LEVEL,PRESSURE_TEST,AK,BK, COFUV1A.34
3 COS_P_LATITUDE,START_U_UPDATE, COFUV1A.35
4 END_U_UPDATE,ROW_LENGTH, APB0F401.1385
*CALL ARGFLDPT 
APB0F401.1386
& LATITUDE_STEP_INVERSE, APB0F401.1387
5 LONGITUDE_STEP_INVERSE,P_FIELD,U_FIELD,P_LEVELS, COFUV1A.37
6 DIFFUSION_COEFFICIENT,DIFFUSION_COEFFICIENT2) COFUV1A.38
COFUV1A.39
IMPLICIT NONE COFUV1A.40
COFUV1A.41
INTEGER COFUV1A.42
* U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID COFUV1A.43
*, P_FIELD !IN DIMENSION OF FIELDS ON PRESSURE GRID COFUV1A.44
*, P_LEVELS !IN NUMBER OF MODEL LEVELS COFUV1A.45
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW COFUV1A.46
*, START_U_UPDATE !IN FIRST POINT TO BE UPDATED. COFUV1A.47
*, END_U_UPDATE !IN LAST POINT TO BE UPDATED. COFUV1A.48
*, LEVEL !CURRENT MODEL LEVEL COFUV1A.49
APB0F401.1388
! All TYPFLDPT arguments are intent IN APB0F401.1389
*CALL TYPFLDPT APB0F401.1390
COFUV1A.50
REAL COFUV1A.51
* PRESSURE(P_FIELD,P_LEVELS) !IN.3-D PRESSURE FIELD U POINTS COFUV1A.52
* ! LEVEL_P=1 SURFACE THEN LEVEL_P=K IS LEVEL K-1 COFUV1A.53
*,DIFFUSION_EW(P_FIELD) !OUT EFFECTIVE EW DIFFUSION COEFFICIENT COFUV1A.54
*,DIFFUSION_NS(P_FIELD) !OUT EFFECTIVE NS DIFFUSION COEFFICIENT COFUV1A.55
COFUV1A.56
COFUV1A.57
REAL COFUV1A.58
* DIFFUSION_COEFFICIENT(P_FIELD) !IN HOLD ON P GRID. FIRST POINT COFUV1A.59
* ! OF ARRAY IS FIRST P POINT ON COFUV1A.60
* ! SECOND P ROW. EAST-WEST COFUV1A.61
* ! DIFFUSION COEFFICIENT. COFUV1A.62
*,DIFFUSION_COEFFICIENT2(P_FIELD) !IN HOLD ON P GRID. FIRST POINT COFUV1A.63
* ! OF ARRAY IS FIRST P POINT ON COFUV1A.64
* ! SECOND P ROW. NORTH-SOUTH COFUV1A.65
* ! DIFFUSION COEFFICIENT. COFUV1A.66
*,AK(P_LEVELS) !IN LAYER AK'S COFUV1A.67
*,BK(P_LEVELS) !IN LAYER BK'S COFUV1A.68
*,COS_P_LATITUDE(P_FIELD) !IN COS(LAT) AT P POINTS COFUV1A.69
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) COFUV1A.70
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA PHI) COFUV1A.71
*, PRESSURE_TEST !IN PRESSURE ALTITUDE LIMIT FOR SLOPE TEST COFUV1A.72
COFUV1A.73
COFUV1A.74
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- COFUV1A.75
! Define local arrays APB0F401.1391
LOGICAL MASK(P_FIELD) ! Indicates of EW_DIFFUSION to be set to APB0F401.1392
! ! zero at a point APB0F401.1393
COFUV1A.76
C DEFINE LOCAL VARIABLES COFUV1A.77
COFUV1A.78
C LOCAL REALS. COFUV1A.79
REAL COFUV1A.80
* PRESSURE_LEVEL COFUV1A.81
COFUV1A.82
C COUNT VARIABLES FOR DO LOOPS ETC. COFUV1A.83
INTEGER COFUV1A.84
* I,IJ,LEVEL_P APB0F401.1394
C LEVEL_P=LEVEL+1 IS FOR PRESSURE TEST COFUV1A.86
C*L EXTERNAL SUBROUTINE CALLS: NONE--------------------------------- COFUV1A.87
COFUV1A.88
C*--------------------------------------------------------------------- COFUV1A.89
CL MAXIMUM VECTOR LENGTH ASSUMED IS END_U_UPDATE-START_U_UPDATE+1+ COFUV1A.90
CL ROW_LENGTH COFUV1A.91
CL--------------------------------------------------------------------- COFUV1A.92
CL INTERNAL STRUCTURE. COFUV1A.93
CL--------------------------------------------------------------------- COFUV1A.94
CL COFUV1A.95
CL--------------------------------------------------------------------- COFUV1A.96
CL SECTION 1. CALCULATE FIRST TERM IN EQUATION (47) COFUV1A.97
CL--------------------------------------------------------------------- COFUV1A.98
COFUV1A.99
C LEVEL_P=LEVEL+1 IS FOR PRESSURE TEST COFUV1A.100
LEVEL_P=LEVEL+1 COFUV1A.101
C---------------------------------------------------------------------- COFUV1A.102
CL TOP LEVEL LEVEL_P = P_LEVELS SINCE SLOPE TEST NEED NOT BE COFUV1A.103
CL DONE FOR TOP MOST (PRESSURE) LEVELS COFUV1A.104
C---------------------------------------------------------------------- COFUV1A.105
IF(LEVEL_P.GT.P_LEVELS)LEVEL_P=P_LEVELS COFUV1A.106
C---------------------------------------------------------------------- COFUV1A.107
CL SECTION 1.1 CALCULATE DELTALAMBDA TERMS COFUV1A.108
C DELTAPHIKLAMBDA*1/(DELTALAMBDA)SQUARED COFUV1A.109
C---------------------------------------------------------------------- COFUV1A.110
COFUV1A.111
DO I= START_U_UPDATE,END_U_UPDATE COFUV1A.112
DIFFUSION_EW(I) = 0.5*(DIFFUSION_COEFFICIENT(I+ROW_LENGTH)+ COFUV1A.113
& DIFFUSION_COEFFICIENT(I))*LONGITUDE_STEP_INVERSE COFUV1A.114
& *LONGITUDE_STEP_INVERSE COFUV1A.115
END DO COFUV1A.116
COFUV1A.117
COFUV1A.118
COFUV1A.119
C---------------------------------------------------------------------- COFUV1A.120
CL SECTION 1.2 SET EFFECTIVE DIFFUSION COEFFICIENT TO ZERO COFUV1A.121
C IF STEEP SLOPE BELOW PRESSURE ALTITUDE LIMIT COFUV1A.122
C APPLY GENERAL TEST AT FIRST POINT ONLY COFUV1A.123
C---------------------------------------------------------------------- COFUV1A.124
COFUV1A.125
C APPLY GENERAL TEST FOR REFERENCE SURFACE PRESSURE OF 1000HPA COFUV1A.126
PRESSURE_LEVEL=AK(LEVEL)+100000.0*BK(LEVEL) COFUV1A.127
IF(PRESSURE_LEVEL.GT.PRESSURE_TEST)THEN COFUV1A.128
COFUV1A.129
DO I= START_U_UPDATE+1,END_U_UPDATE APB0F401.1395
MASK(I)=((PRESSURE(I-1,LEVEL_P).GT.PRESSURE(I,LEVEL_P-1)).OR. APB0F401.1396
& (PRESSURE(I-1,LEVEL_P).LT.PRESSURE(I,LEVEL_P+1))) APB0F401.1397
ENDDO APB0F401.1398
APB0F401.1399
*IF -DEF,MPP APB0F401.1400
! Recalculate end-points APB0F401.1401
DO I=START_U_UPDATE,END_U_UPDATE,ROW_LENGTH APB0F401.1402
IJ=I+ROW_LENGTH-1 APB0F401.1403
MASK(I)=((PRESSURE(IJ,LEVEL_P).GT.PRESSURE(I,LEVEL_P-1)).OR. APB0F401.1404
& (PRESSURE(IJ,LEVEL_P).LT.PRESSURE(I,LEVEL_P+1))) APB0F401.1405
ENDDO APB0F401.1406
*ENDIF APB0F401.1407
APB0F401.1408
! And zero appropriate points of EW_DIFFUSION APB0F401.1409
DO I= START_U_UPDATE,END_U_UPDATE APB0F401.1410
IF (MASK(I)) DIFFUSION_EW(I)=0.0 APB0F401.1411
ENDDO APB0F401.1412
COFUV1A.151
ENDIF COFUV1A.152
COFUV1A.153
COFUV1A.154
CL--------------------------------------------------------------------- COFUV1A.155
CL SECTION 2. CALCULATE SECOND TERM IN EQUATION (47) COFUV1A.156
CL--------------------------------------------------------------------- COFUV1A.157
COFUV1A.158
C---------------------------------------------------------------------- COFUV1A.159
CL SECTION 2.1 CALCULATE DELTAPHI TERMS COFUV1A.160
CL CALCULATE DELTALAMBDAK*COSLAT/(DELTAPHI)SQUARED COFUV1A.161
C---------------------------------------------------------------------- COFUV1A.162
COFUV1A.163
! Loop over field missing Northern row APB0F401.1413
DO I=START_POINT_NO_HALO,LAST_U_FLD_PT-1 APB0F401.1414
DIFFUSION_NS(I)=0.5*(DIFFUSION_COEFFICIENT2(I)*COS_P_LATITUDE(I) COFUV1A.165
& +DIFFUSION_COEFFICIENT2(I+1)*COS_P_LATITUDE(I+1))* COFUV1A.166
& LATITUDE_STEP_INVERSE*LATITUDE_STEP_INVERSE COFUV1A.167
END DO COFUV1A.168
COFUV1A.169
C RECALCULATE END POINTS. COFUV1A.170
COFUV1A.171
*IF -DEF,MPP APB0F401.1415
DO I=1+ROW_LENGTH,U_FIELD,ROW_LENGTH COFUV1A.172
IJ = I+ROW_LENGTH-1 COFUV1A.173
DIFFUSION_NS(IJ)=0.5* COFUV1A.174
& (DIFFUSION_COEFFICIENT2(I)*COS_P_LATITUDE(I) COFUV1A.175
& +DIFFUSION_COEFFICIENT2(IJ)*COS_P_LATITUDE(IJ))* COFUV1A.176
& LATITUDE_STEP_INVERSE*LATITUDE_STEP_INVERSE COFUV1A.177
END DO COFUV1A.178
*ELSE APB0F401.1416
DIFFUSION_NS(LAST_U_FLD_PT)=DIFFUSION_NS(LAST_U_FLD_PT-1) APB0F401.1417
*ENDIF APB0F401.1418
COFUV1A.179
COFUV1A.180
*IF DEF,GLOBAL COFUV1A.181
C CALCULATE POLAR TERMS USING ACROSS-POLE DIFFERENCE, REMEMBERING SIGN COFUV1A.182
C CHANGE ACROSS THE POLE COFUV1A.183
C NB: EFFECTIVE COS_P_LATITUDE IS 1/4 THAT AT ADJACENT ROW COFUV1A.184
COFUV1A.185
APB0F401.1419
*IF DEF,MPP APB0F401.1420
IF (at_top_of_LPG) THEN APB0F401.1421
*ENDIF APB0F401.1422
! North Pole APB0F401.1423
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB0F401.1424
DIFFUSION_NS(I)=DIFFUSION_COEFFICIENT2(I)*COS_P_LATITUDE(I)* APB0F401.1425
& LATITUDE_STEP_INVERSE*LATITUDE_STEP_INVERSE APB0F401.1426
ENDDO APB0F401.1427
*IF DEF,MPP APB0F401.1428
ENDIF APB0F401.1429
APB0F401.1430
IF (at_base_of_LPG) THEN APB0F401.1431
*ENDIF APB0F401.1432
! South Pole APB0F401.1433
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 APB0F401.1434
DIFFUSION_NS(I)=DIFFUSION_COEFFICIENT2(I)*COS_P_LATITUDE(I)* APB0F401.1435
& LATITUDE_STEP_INVERSE*LATITUDE_STEP_INVERSE APB0F401.1436
ENDDO APB0F401.1437
*IF DEF,MPP APB0F401.1438
ENDIF APB0F401.1439
*ENDIF APB0F401.1440
*ENDIF COFUV1A.204
COFUV1A.205
COFUV1A.206
C---------------------------------------------------------------------- COFUV1A.207
CL SECTION 2.2 SET EFFECTIVE DIFFUSION COEFFICIENT TO ZERO COFUV1A.208
C IF STEEP SLOPE BELOW PRESSURE ALTITUDE LIMIT COFUV1A.209
C APPLY GENERAL TEST AT FIRST POINT ONLY COFUV1A.210
C---------------------------------------------------------------------- COFUV1A.211
COFUV1A.212
C APPLY GENERAL TEST FOR REFERENCE SURFACE PRESSURE OF 1000HPA COFUV1A.213
IF(PRESSURE_LEVEL.GT.PRESSURE_TEST)THEN COFUV1A.214
COFUV1A.215
! Loop over field, missing Northern row APB0F401.1441
DO I=START_POINT_NO_HALO,LAST_U_FLD_PT APB0F401.1442
IF((PRESSURE(I,LEVEL_P).GT.PRESSURE(I-ROW_LENGTH,LEVEL_P-1)).OR. COFUV1A.217
& (PRESSURE(I,LEVEL_P).LT. COFUV1A.218
& PRESSURE(I-ROW_LENGTH,LEVEL_P+1)))THEN COFUV1A.219
DIFFUSION_NS(I)=0.0 COFUV1A.220
ENDIF COFUV1A.221
COFUV1A.222
END DO COFUV1A.223
COFUV1A.224
ENDIF COFUV1A.225
COFUV1A.226
CL END OF ROUTINE COEFF_UV COFUV1A.227
COFUV1A.228
RETURN COFUV1A.229
END COFUV1A.230
*ENDIF COFUV1A.231