*IF DEF,A13_1A,OR,DEF,A13_1B ATJ0F402.28
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.14895
C GTS2F400.14896
C Use, duplication or disclosure of this code is subject to the GTS2F400.14897
C restrictions as set forth in the contract. GTS2F400.14898
C GTS2F400.14899
C Meteorological Office GTS2F400.14900
C London Road GTS2F400.14901
C BRACKNELL GTS2F400.14902
C Berkshire UK GTS2F400.14903
C RG12 2SZ GTS2F400.14904
C GTS2F400.14905
C If no contract has been raised with this copy of the code, the use, GTS2F400.14906
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.14907
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.14908
C Modelling at the above address. GTS2F400.14909
C ******************************COPYRIGHT****************************** GTS2F400.14910
C GTS2F400.14911
CLL SUBROUTINE COEFF_TH_Q ----------------------------------------- COFTHQ1A.3
CLL COFTHQ1A.4
CLL PURPOSE: CALCULATES EFFECTIVE DIFFUSION COEFFICIENTS COFTHQ1A.5
CLL FOR THETAL OR Q IN NS AND EW DIRECTIONS COFTHQ1A.6
CLL IF STEEP SLOPE THEN EFFECTIVE DIFFUSION IS ZERO. COFTHQ1A.7
CLL COFTHQ1A.8
CLL NOTE PRESSURE ARRAY NEEDS TO BE GLOBAL (SHARED) COFTHQ1A.9
CLL FOR MULTI-TASKING AT 3.4 UPWARDS. COFTHQ1A.10
CLL COFTHQ1A.11
CLL NOT SUITABLE FOR SINGLE COLUMN USE. COFTHQ1A.12
CLL COFTHQ1A.13
CLL VERSION FOR CRAY Y-MP COFTHQ1A.14
CLL COFTHQ1A.15
CLL MODEL MODIFICATION HISTORY COFTHQ1A.16
CLL VERSION DATE COFTHQ1A.17
CLL 4.0 03/02/95 NEW SUBROUTINE CALLED BY DIF_CTL COFTHQ1A.18
CLL AUTHOR: T.DAVIES FR. REVIEWER: M MAWSON COFTHQ1A.19
! 4.1 07/05/96 Added MPP code and TYPFLDPT arguments and fixed APB0F401.1345
! bug in wrap-arounds P.Burton APB0F401.1346
CLL COFTHQ1A.20
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, COFTHQ1A.21
CLL STANDARD B. VERSION 2, DATED 18/01/90 COFTHQ1A.22
CLL COFTHQ1A.23
CLL SYSTEM COMPONENTS COVERED: P131 COFTHQ1A.24
CLL COFTHQ1A.25
CLL SYSTEM TASK: P1 COFTHQ1A.26
CLL COFTHQ1A.27
CLL DOCUMENTATION: THE EQUATION USED IS (47) COFTHQ1A.28
CLL IN UNIFIED MODEL DOCUMENTATION PAPER COFTHQ1A.29
CLL NO. 10 M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON COFTHQ1A.30
CLL VERSION 16, DATED 09/01/91. COFTHQ1A.31
CLLEND------------------------------------------------------------- COFTHQ1A.32
COFTHQ1A.33
C*L ARGUMENTS:--------------------------------------------------- COFTHQ1A.34
SUBROUTINE COEFF_TH_Q 4,2COFTHQ1A.35
1 (DIFFUSION_EW,DIFFUSION_NS, COFTHQ1A.36
2 PRESSURE,LEVEL,PRESSURE_TEST,AK,BK, COFTHQ1A.37
3 COS_U_LATITUDE,ROW_LENGTH, APB0F401.1347
*CALL ARGFLDPT 
APB0F401.1348
5 LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, COFTHQ1A.40
6 P_FIELD,U_FIELD,P_LEVELS, COFTHQ1A.41
7 DIFFUSION_COEFFICIENT,DIFFUSION_COEFFICIENT2) COFTHQ1A.42
COFTHQ1A.43
IMPLICIT NONE COFTHQ1A.44
COFTHQ1A.45
INTEGER COFTHQ1A.46
* U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID COFTHQ1A.47
*, P_FIELD !IN DIMENSION OF FIELDS ON PRESSURE GRID COFTHQ1A.48
*, P_LEVELS !IN NUMBER OF MODEL LEVELS COFTHQ1A.49
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW COFTHQ1A.50
*, LEVEL ! MODEL LEVEL FOR DIFFUSION COFTHQ1A.53
APB0F401.1349
! All TYPFLDPT arguments are intent IN APB0F401.1350
*CALL TYPFLDPT APB0F401.1351
COFTHQ1A.54
REAL COFTHQ1A.55
* DIFFUSION_EW(P_FIELD) !OUT HOLDS EAST-WEST COFTHQ1A.56
* !EFFECTIVE DIFFUSION COEFFICIENT. COFTHQ1A.57
*,DIFFUSION_NS(P_FIELD) !OUT HOLDS NORTH_SOUTH COFTHQ1A.58
* !EFFECTIVE DIFFUSION COEFFICIENT. COFTHQ1A.59
COFTHQ1A.60
REAL COFTHQ1A.61
* PRESSURE(P_FIELD,P_LEVELS) !IN HOLDS 3-D PRESSURE FIELD COFTHQ1A.62
* ! LEVEL=1 IS SURFACE THEN LEVEL=K IS MODEL LEVEL K-1 COFTHQ1A.63
*,DIFFUSION_COEFFICIENT(U_FIELD) !IN HOLDS EAST-WEST DIFFUSION COFTHQ1A.64
* ! COEFFICIENT. COFTHQ1A.65
*,DIFFUSION_COEFFICIENT2(U_FIELD) !IN HOLDS NORTH-SOUTH DIFFUSION COFTHQ1A.66
* ! COEFFICIENT. COFTHQ1A.67
*,AK(P_LEVELS) !IN LAYER AK'S COFTHQ1A.68
*,BK(P_LEVELS) !IN LAYER BK'S COFTHQ1A.69
*,COS_U_LATITUDE(U_FIELD) !IN COS(LAT) AT U POINTS COFTHQ1A.70
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) COFTHQ1A.71
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA PHI) COFTHQ1A.72
*, PRESSURE_TEST ! PRESSURE ALTITUDE LIMIT FOR SLOPE TEST COFTHQ1A.73
COFTHQ1A.74
C*--------------------------------------------------------------------- COFTHQ1A.75
COFTHQ1A.76
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- COFTHQ1A.77
C*--------------------------------------------------------------------- COFTHQ1A.78
! Define local arrays APB0F401.1352
LOGICAL MASK(P_FIELD) ! Indicates of EW_DIFFUSION to be set to APB0F401.1353
! ! zero at a point APB0F401.1354
C DEFINE LOCAL VARIABLES COFTHQ1A.79
COFTHQ1A.80
C LOCAL REALS. COFTHQ1A.81
REAL COFTHQ1A.82
* PRESSURE_LEVEL COFTHQ1A.83
COFTHQ1A.84
C COUNT VARIABLES FOR DO LOOPS ETC. COFTHQ1A.85
INTEGER COFTHQ1A.86
* I,IJ,LEVEL_P COFTHQ1A.87
COFTHQ1A.88
C*L EXTERNAL SUBROUTINE CALLS: NONE------------------------------ COFTHQ1A.89
COFTHQ1A.90
C*--------------------------------------------------------------------- COFTHQ1A.91
CL MAXIMUM VECTOR LENGTH ASSUMED IS END_P_UPDATE-START_P_UPDATE+1 COFTHQ1A.92
CL--------------------------------------------------------------------- COFTHQ1A.93
CL INTERNAL STRUCTURE. COFTHQ1A.94
CL--------------------------------------------------------------------- COFTHQ1A.95
CL COFTHQ1A.96
CL--------------------------------------------------------------------- COFTHQ1A.97
CL SECTION 1. DELTALAMBDA TERMS COFTHQ1A.98
CL--------------------------------------------------------------------- COFTHQ1A.99
LEVEL_P=LEVEL+1 COFTHQ1A.100
C---------------------------------------------------------------------- COFTHQ1A.101
C LEVEL_P =LEVEL+1 SINCE LEVEL_P=1 IS THE SURFACE COFTHQ1A.102
CL TOP LEVEL LEVEL_P = P_LEVELS SINCE SLOPE TEST NEED NOT BE COFTHQ1A.103
CL DONE FOR TOP MOST (PRESSURE) LEVELS COFTHQ1A.104
C---------------------------------------------------------------------- COFTHQ1A.105
IF(LEVEL_P.GT.P_LEVELS)LEVEL_P=P_LEVELS COFTHQ1A.106
C---------------------------------------------------------------------- COFTHQ1A.107
CL SECTION 1.1 CALCULATE DELTAPHILAMBDA*1/(DELTALAMBDA)SQUARED COFTHQ1A.108
C---------------------------------------------------------------------- COFTHQ1A.109
COFTHQ1A.110
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1355
DIFFUSION_EW(I) = 0.5*(DIFFUSION_COEFFICIENT(I-ROW_LENGTH)+ COFTHQ1A.112
& DIFFUSION_COEFFICIENT(I))*LONGITUDE_STEP_INVERSE COFTHQ1A.113
& *LONGITUDE_STEP_INVERSE COFTHQ1A.114
END DO COFTHQ1A.115
COFTHQ1A.116
C---------------------------------------------------------------------- COFTHQ1A.117
CL TEST TO SEE IF DIFFUSION COEFFICIENT SET TO ZERO COFTHQ1A.118
C IF STEEP SLOPE AT PRESSURE > PRESSURE_TEST ONLY COFTHQ1A.119
C APPLY GENERAL TEST FOR REFERENCE SURFACE PRESSURE OF 1000HPA COFTHQ1A.120
PRESSURE_LEVEL=AK(LEVEL)+100000.0*BK(LEVEL) COFTHQ1A.121
C COFTHQ1A.122
IF(PRESSURE_LEVEL.GT.PRESSURE_TEST)THEN COFTHQ1A.123
COFTHQ1A.124
C---------------------------------------------------------------------- COFTHQ1A.125
CL SECTION 1.2 SET EFFECTIVE DIFFUSION COEFFICIENT TO ZERO COFTHQ1A.126
C IF STEEP SLOPE BELOW CHOSEN LEVEL COFTHQ1A.127
C---------------------------------------------------------------------- COFTHQ1A.128
COFTHQ1A.129
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO-1 APB0F401.1356
MASK(I)=((PRESSURE(I,LEVEL_P).GT.PRESSURE(I+1,LEVEL_P-1)).OR. APB0F401.1357
& (PRESSURE(I,LEVEL_P).LT.PRESSURE(I+1,LEVEL_P+1))) APB0F401.1358
ENDDO APB0F401.1359
APB0F401.1360
*IF -DEF,MPP APB0F401.1361
! Recalculate end-points APB0F401.1362
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.1363
IJ=I+ROW_LENGTH-1 APB0F401.1364
MASK(IJ)=((PRESSURE(IJ,LEVEL_P).GT.PRESSURE(I,LEVEL_P-1)).OR. APB0F401.1365
& (PRESSURE(IJ,LEVEL_P).LT.PRESSURE(I,LEVEL_P+1))) APB0F401.1366
ENDDO APB0F401.1367
*ENDIF APB0F401.1368
APB0F401.1369
! And zero appropriate points of EW_DIFFUSION APB0F401.1370
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1371
IF (MASK(I)) DIFFUSION_EW(I)=0.0 APB0F401.1372
ENDDO APB0F401.1373
COFTHQ1A.149
ENDIF COFTHQ1A.150
COFTHQ1A.151
COFTHQ1A.152
C---------------------------------------------------------------------- COFTHQ1A.153
CL SECTION 2 CALCULATE NS EFFECTIVE DIFFUSION COFTHQ1A.154
C---------------------------------------------------------------------- COFTHQ1A.155
COFTHQ1A.156
C CALCULATE DELTAPHI TERMS COFTHQ1A.157
C DELTALAMBDAK*COSLAT/(DELTAPHI)SQUARED COFTHQ1A.158
COFTHQ1A.159
DO I= START_POINT_NO_HALO-ROW_LENGTH+1,END_P_POINT_NO_HALO APB0F401.1374
DIFFUSION_NS(I)=0.5*(DIFFUSION_COEFFICIENT2(I)*COS_U_LATITUDE(I) COFTHQ1A.161
& +DIFFUSION_COEFFICIENT2(I-1)*COS_U_LATITUDE(I-1))* COFTHQ1A.162
& LATITUDE_STEP_INVERSE*LATITUDE_STEP_INVERSE COFTHQ1A.163
END DO COFTHQ1A.164
COFTHQ1A.165
C RECALCULATE END-POINTS COFTHQ1A.166
COFTHQ1A.167
COFTHQ1A.168
*IF -DEF,MPP APB0F401.1375
DO I=START_POINT_NO_HALO-ROW_LENGTH,END_P_POINT_NO_HALO, APB0F401.1376
& ROW_LENGTH APB0F401.1377
IJ=I+ROW_LENGTH-1 COFTHQ1A.170
DIFFUSION_NS(I)=0.5*(DIFFUSION_COEFFICIENT2(I)*COS_U_LATITUDE(I) COFTHQ1A.171
& +DIFFUSION_COEFFICIENT2(IJ)*COS_U_LATITUDE(IJ))* COFTHQ1A.172
& LATITUDE_STEP_INVERSE*LATITUDE_STEP_INVERSE COFTHQ1A.173
END DO COFTHQ1A.174
*ELSE APB0F401.1378
DIFFUSION_NS(START_POINT_NO_HALO-ROW_LENGTH)= APB0F401.1379
& DIFFUSION_NS(START_POINT_NO_HALO-ROW_LENGTH+1) APB0F401.1380
*ENDIF APB0F401.1381
COFTHQ1A.175
C---------------------------------------------------------------------- COFTHQ1A.176
CL SECTION 2.2 SET EFFECTIVE DIFFUSION COEFFICIENT TO ZERO COFTHQ1A.177
C IF STEEP SLOPE COFTHQ1A.178
C---------------------------------------------------------------------- COFTHQ1A.179
CL TEST TO SEE IF DIFFUSION COEFFICIENT SET TO ZERO COFTHQ1A.180
C IF STEEP SLOPE AT PRESSURE > PRESSURE_TEST ONLY COFTHQ1A.181
C APPLY GENERAL TEST FOR REFERENCE SURFACE PRESSURE OF 1000HPA COFTHQ1A.182
C COFTHQ1A.183
IF(PRESSURE_LEVEL.GT.PRESSURE_TEST)THEN COFTHQ1A.184
COFTHQ1A.185
DO I=START_POINT_NO_HALO-ROW_LENGTH,END_P_POINT_NO_HALO APB0F401.1382
IF((PRESSURE(I+ROW_LENGTH,LEVEL_P).GT.PRESSURE(I,LEVEL_P-1)).OR. COFTHQ1A.187
& (PRESSURE(I+ROW_LENGTH,LEVEL_P).LT. COFTHQ1A.188
& PRESSURE(I,LEVEL_P+1)))THEN COFTHQ1A.189
DIFFUSION_NS(I)=0.0 COFTHQ1A.190
ENDIF COFTHQ1A.191
END DO COFTHQ1A.192
COFTHQ1A.193
ENDIF COFTHQ1A.194
COFTHQ1A.195
CL END OF ROUTINE COEFF_TH_Q COFTHQ1A.196
COFTHQ1A.197
RETURN COFTHQ1A.198
END COFTHQ1A.199
*ENDIF COFTHQ1A.200