*IF DEF,A13_1C COFTHQ1C.2
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. COFTHQ1C.3
C COFTHQ1C.4
C Use, duplication or disclosure of this code is subject to the COFTHQ1C.5
C restrictions as set forth in the contract. COFTHQ1C.6
C COFTHQ1C.7
C Meteorological Office COFTHQ1C.8
C London Road COFTHQ1C.9
C BRACKNELL COFTHQ1C.10
C Berkshire UK COFTHQ1C.11
C RG12 2SZ COFTHQ1C.12
C COFTHQ1C.13
C If no contract has been raised with this copy of the code, the use, COFTHQ1C.14
C duplication or disclosure of it is strictly prohibited. Permission COFTHQ1C.15
C to do so must first be obtained in writing from the Head of Numerical COFTHQ1C.16
C Modelling at the above address. COFTHQ1C.17
C ******************************COPYRIGHT****************************** COFTHQ1C.18
C COFTHQ1C.19
CLL SUBROUTINE COEFF_TH_Q ----------------------------------------- COFTHQ1C.20
CLL COFTHQ1C.21
CLL PURPOSE: CALCULATES EFFECTIVE DIFFUSION COEFFICIENTS COFTHQ1C.22
CLL FOR THETAL OR Q IN NS AND EW DIRECTIONS COFTHQ1C.23
CLL IF STEEP SLOPE THEN EFFECTIVE DIFFUSION IS ZERO. COFTHQ1C.24
CLL COFTHQ1C.25
CLL NOTE PRESSURE ARRAY NEEDS TO BE GLOBAL (SHARED) COFTHQ1C.26
CLL FOR MULTI-TASKING AT 3.4 UPWARDS. COFTHQ1C.27
CLL COFTHQ1C.28
CLL NOT SUITABLE FOR SINGLE COLUMN USE. COFTHQ1C.29
CLL COFTHQ1C.30
CLL WAS VERSION FOR CRAY Y-MP COFTHQ1C.31
CLL COFTHQ1C.32
CLL MODEL MODIFICATION HISTORY COFTHQ1C.33
CLL VERSION DATE COFTHQ1C.34
!LL 4.4 11/08/97 New version optimised for T3E. COFTHQ1C.35
!LL Not bit-reproducible with COFTHQ1A. COFTHQ1C.36
CLL 4.4 25/07/97 Calling sequence changed from once per level COFTHQ1C.37
CLL to once per dynamics sweep, in COFTHQ1C.38
CLL order to improve MPP scalability. COFTHQ1C.39
CLL A. Dickinson COFTHQ1C.40
CLL COFTHQ1C.41
CLL COFTHQ1C.42
CLL PROGRAMMING STANDARD: COFTHQ1C.43
CLL COFTHQ1C.44
CLL SYSTEM COMPONENTS COVERED: P131 COFTHQ1C.45
CLL COFTHQ1C.46
CLL SYSTEM TASK: P1 COFTHQ1C.47
CLL COFTHQ1C.48
CLL DOCUMENTATION: THE EQUATION USED IS (47) COFTHQ1C.49
CLL IN UNIFIED MODEL DOCUMENTATION PAPER COFTHQ1C.50
CLL NO. 10 M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON COFTHQ1C.51
CLL VERSION 16, DATED 09/01/91. COFTHQ1C.52
CLLEND------------------------------------------------------------- COFTHQ1C.53
COFTHQ1C.54
C*L ARGUMENTS:--------------------------------------------------- COFTHQ1C.55
SUBROUTINE COEFF_TH_Q 4,2COFTHQ1C.56
1 (DIFFUSION_EW,DIFFUSION_NS, COFTHQ1C.57
2 PRESSURE,LEVEL_BASE,PRESSURE_TEST,AK,BK, COFTHQ1C.58
3 COS_U_LATITUDE,ROW_LENGTH, COFTHQ1C.59
*CALL ARGFLDPT 
COFTHQ1C.60
5 LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, COFTHQ1C.61
6 P_FIELD,U_FIELD,P_LEVELS, COFTHQ1C.62
7 KD,DELTA_AK,DELTA_BK,PSTAR_UV,COS_FUNCTION_U) COFTHQ1C.63
COFTHQ1C.64
IMPLICIT NONE COFTHQ1C.65
COFTHQ1C.66
INTEGER COFTHQ1C.67
* U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID COFTHQ1C.68
*, P_FIELD !IN DIMENSION OF FIELDS ON PRESSURE GRID COFTHQ1C.69
*, P_LEVELS !IN NUMBER OF MODEL LEVELS COFTHQ1C.70
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW COFTHQ1C.71
*, LEVEL_BASE !IN BOTTOM MODEL LEVEL FOR DIFFUSION COFTHQ1C.72
! All TYPFLDPT arguments are intent IN COFTHQ1C.73
*CALL TYPFLDPT COFTHQ1C.74
COFTHQ1C.75
REAL COFTHQ1C.76
* DIFFUSION_EW(P_FIELD,P_LEVELS) !OUT HOLDS EAST-WEST COFTHQ1C.77
* !EFFECTIVE DIFFUSION COEFFICIENT. COFTHQ1C.78
*,DIFFUSION_NS(P_FIELD,P_LEVELS) !OUT HOLDS NORTH_SOUTH COFTHQ1C.79
* !EFFECTIVE DIFFUSION COEFFICIENT. COFTHQ1C.80
COFTHQ1C.81
REAL COFTHQ1C.82
* PRESSURE(P_FIELD,P_LEVELS) !IN HOLDS 3-D PRESSURE FIELD COFTHQ1C.83
* ! LEVEL=1 IS SURFACE THEN LEVEL=K IS MODEL LEVEL K-1 COFTHQ1C.84
*,AK(P_LEVELS) !IN LAYER AK'S COFTHQ1C.85
*,BK(P_LEVELS) !IN LAYER BK'S COFTHQ1C.86
*,DELTA_AK(P_LEVELS) !IN LAYER DELTA_AK'S COFTHQ1C.87
*,DELTA_BK(P_LEVELS) !IN LAYER DELTA_BK'S COFTHQ1C.88
*,KD(P_LEVELS) !IN DIFFUSION COEFF SEE EQ. (45) COFTHQ1C.89
*,PSTAR_UV(U_FIELD) !IN PSTAR AT U POINTS COFTHQ1C.90
*,COS_U_LATITUDE(U_FIELD) !IN COS(LAT) AT U POINTS COFTHQ1C.91
*,COS_FUNCTION_U(U_FIELD) !IN COFTHQ1C.92
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) COFTHQ1C.93
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA PHI) COFTHQ1C.94
*, PRESSURE_TEST ! PRESSURE ALTITUDE LIMIT FOR SLOPE TEST COFTHQ1C.95
COFTHQ1C.96
C*--------------------------------------------------------------------- COFTHQ1C.97
COFTHQ1C.98
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- COFTHQ1C.99
C*--------------------------------------------------------------------- COFTHQ1C.100
! Define local arrays COFTHQ1C.101
LOGICAL MASK(P_FIELD) ! Indicates of EW_DIFFUSION to be set to COFTHQ1C.102
COFTHQ1C.103
REAL COFTHQ1C.104
* DIFFUSION_COEFFICIENT(U_FIELD) ! HOLDS EAST-WEST DIFFUSION COFTHQ1C.105
* ! COEFFICIENT. COFTHQ1C.106
*,DIFFUSION_COEFFICIENT2(U_FIELD) ! HOLDS NORTH-SOUTH DIFFUSION COFTHQ1C.107
* ! COEFFICIENT. COFTHQ1C.108
! ! zero at a point COFTHQ1C.109
C DEFINE LOCAL VARIABLES COFTHQ1C.110
COFTHQ1C.111
C LOCAL REALS. COFTHQ1C.112
REAL COFTHQ1C.113
* PRESSURE_LEVEL COFTHQ1C.114
COFTHQ1C.115
C COUNT VARIABLES FOR DO LOOPS ETC. COFTHQ1C.116
INTEGER COFTHQ1C.117
* I,IJ,LEVEL_P,LEVEL COFTHQ1C.118
COFTHQ1C.119
C*L EXTERNAL SUBROUTINE CALLS: NONE------------------------------ COFTHQ1C.120
COFTHQ1C.121
C*--------------------------------------------------------------------- COFTHQ1C.122
CL MAXIMUM VECTOR LENGTH ASSUMED IS END_P_UPDATE-START_P_UPDATE+1 COFTHQ1C.123
CL--------------------------------------------------------------------- COFTHQ1C.124
CL INTERNAL STRUCTURE. COFTHQ1C.125
CL--------------------------------------------------------------------- COFTHQ1C.126
CL COFTHQ1C.127
COFTHQ1C.128
DO LEVEL=LEVEL_BASE,P_LEVELS COFTHQ1C.129
COFTHQ1C.130
C SET DIFFUSION COEFFICIENT AND COPY THETAL INTO FIELD1. COFTHQ1C.131
DO I=FIRST_VALID_PT,LAST_U_VALID_PT COFTHQ1C.132
DIFFUSION_COEFFICIENT2(I) = KD(LEVEL)* COFTHQ1C.133
1 (DELTA_AK(LEVEL)+DELTA_BK(LEVEL)*PSTAR_UV(I)) COFTHQ1C.134
DIFFUSION_COEFFICIENT(I) = COS_FUNCTION_U(I)* COFTHQ1C.135
2 DIFFUSION_COEFFICIENT2(I) COFTHQ1C.136
END DO COFTHQ1C.137
COFTHQ1C.138
COFTHQ1C.139
CL--------------------------------------------------------------------- COFTHQ1C.140
CL SECTION 1. DELTALAMBDA TERMS COFTHQ1C.141
CL--------------------------------------------------------------------- COFTHQ1C.142
LEVEL_P=LEVEL+1 COFTHQ1C.143
C---------------------------------------------------------------------- COFTHQ1C.144
C LEVEL_P =LEVEL+1 SINCE LEVEL_P=1 IS THE SURFACE COFTHQ1C.145
CL TOP LEVEL LEVEL_P = P_LEVELS SINCE SLOPE TEST NEED NOT BE COFTHQ1C.146
CL DONE FOR TOP MOST (PRESSURE) LEVELS COFTHQ1C.147
C---------------------------------------------------------------------- COFTHQ1C.148
IF(LEVEL_P.GT.P_LEVELS)LEVEL_P=P_LEVELS COFTHQ1C.149
C---------------------------------------------------------------------- COFTHQ1C.150
CL SECTION 1.1 CALCULATE DELTAPHILAMBDA*1/(DELTALAMBDA)SQUARED COFTHQ1C.151
C---------------------------------------------------------------------- COFTHQ1C.152
COFTHQ1C.153
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO COFTHQ1C.154
DIFFUSION_EW(I,LEVEL) = 0.5*(DIFFUSION_COEFFICIENT(I-ROW_LENGTH) COFTHQ1C.155
& + DIFFUSION_COEFFICIENT(I))*LONGITUDE_STEP_INVERSE COFTHQ1C.156
& *LONGITUDE_STEP_INVERSE COFTHQ1C.157
END DO COFTHQ1C.158
COFTHQ1C.159
C---------------------------------------------------------------------- COFTHQ1C.160
CL TEST TO SEE IF DIFFUSION COEFFICIENT SET TO ZERO COFTHQ1C.161
C IF STEEP SLOPE AT PRESSURE > PRESSURE_TEST ONLY COFTHQ1C.162
C APPLY GENERAL TEST FOR REFERENCE SURFACE PRESSURE OF 1000HPA COFTHQ1C.163
PRESSURE_LEVEL=AK(LEVEL)+100000.0*BK(LEVEL) COFTHQ1C.164
C COFTHQ1C.165
IF(PRESSURE_LEVEL.GT.PRESSURE_TEST)THEN COFTHQ1C.166
COFTHQ1C.167
C---------------------------------------------------------------------- COFTHQ1C.168
CL SECTION 1.2 SET EFFECTIVE DIFFUSION COEFFICIENT TO ZERO COFTHQ1C.169
C IF STEEP SLOPE BELOW CHOSEN LEVEL COFTHQ1C.170
C---------------------------------------------------------------------- COFTHQ1C.171
COFTHQ1C.172
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO-1 COFTHQ1C.173
MASK(I)=((PRESSURE(I,LEVEL_P).GT.PRESSURE(I+1,LEVEL_P-1)).OR. COFTHQ1C.174
& (PRESSURE(I,LEVEL_P).LT.PRESSURE(I+1,LEVEL_P+1))) COFTHQ1C.175
ENDDO COFTHQ1C.176
COFTHQ1C.177
*IF -DEF,MPP COFTHQ1C.178
! Recalculate end-points COFTHQ1C.179
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO,ROW_LENGTH COFTHQ1C.180
IJ=I+ROW_LENGTH-1 COFTHQ1C.181
MASK(IJ)=((PRESSURE(IJ,LEVEL_P).GT.PRESSURE(I,LEVEL_P-1)).OR. COFTHQ1C.182
& (PRESSURE(IJ,LEVEL_P).LT.PRESSURE(I,LEVEL_P+1))) COFTHQ1C.183
ENDDO COFTHQ1C.184
*ENDIF COFTHQ1C.185
COFTHQ1C.186
! And zero appropriate points of EW_DIFFUSION COFTHQ1C.187
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO COFTHQ1C.188
IF (MASK(I)) DIFFUSION_EW(I,LEVEL)=0.0 COFTHQ1C.189
ENDDO COFTHQ1C.190
COFTHQ1C.191
ENDIF COFTHQ1C.192
COFTHQ1C.193
COFTHQ1C.194
C---------------------------------------------------------------------- COFTHQ1C.195
CL SECTION 2 CALCULATE NS EFFECTIVE DIFFUSION COFTHQ1C.196
C---------------------------------------------------------------------- COFTHQ1C.197
COFTHQ1C.198
C CALCULATE DELTAPHI TERMS COFTHQ1C.199
C DELTALAMBDAK*COSLAT/(DELTAPHI)SQUARED COFTHQ1C.200
COFTHQ1C.201
DO I= START_POINT_NO_HALO-ROW_LENGTH+1,END_P_POINT_NO_HALO COFTHQ1C.202
DIFFUSION_NS(I,LEVEL)=0.5*(DIFFUSION_COEFFICIENT2(I) COFTHQ1C.203
& *COS_U_LATITUDE(I) COFTHQ1C.204
& +DIFFUSION_COEFFICIENT2(I-1)*COS_U_LATITUDE(I-1))* COFTHQ1C.205
& LATITUDE_STEP_INVERSE*LATITUDE_STEP_INVERSE COFTHQ1C.206
END DO COFTHQ1C.207
COFTHQ1C.208
C RECALCULATE END-POINTS COFTHQ1C.209
COFTHQ1C.210
COFTHQ1C.211
*IF -DEF,MPP COFTHQ1C.212
DO I=START_POINT_NO_HALO-ROW_LENGTH,END_P_POINT_NO_HALO, COFTHQ1C.213
& ROW_LENGTH COFTHQ1C.214
IJ=I+ROW_LENGTH-1 COFTHQ1C.215
DIFFUSION_NS(I,LEVEL)=0.5*(DIFFUSION_COEFFICIENT2(I) COFTHQ1C.216
& *COS_U_LATITUDE(I) COFTHQ1C.217
& +DIFFUSION_COEFFICIENT2(IJ)*COS_U_LATITUDE(IJ))* COFTHQ1C.218
& LATITUDE_STEP_INVERSE*LATITUDE_STEP_INVERSE COFTHQ1C.219
END DO COFTHQ1C.220
*ELSE COFTHQ1C.221
DIFFUSION_NS(START_POINT_NO_HALO-ROW_LENGTH,LEVEL)= COFTHQ1C.222
& DIFFUSION_NS(START_POINT_NO_HALO-ROW_LENGTH+1,LEVEL) COFTHQ1C.223
*ENDIF COFTHQ1C.224
COFTHQ1C.225
C---------------------------------------------------------------------- COFTHQ1C.226
CL SECTION 2.2 SET EFFECTIVE DIFFUSION COEFFICIENT TO ZERO COFTHQ1C.227
C IF STEEP SLOPE COFTHQ1C.228
C---------------------------------------------------------------------- COFTHQ1C.229
CL TEST TO SEE IF DIFFUSION COEFFICIENT SET TO ZERO COFTHQ1C.230
C IF STEEP SLOPE AT PRESSURE > PRESSURE_TEST ONLY COFTHQ1C.231
C APPLY GENERAL TEST FOR REFERENCE SURFACE PRESSURE OF 1000HPA COFTHQ1C.232
C COFTHQ1C.233
IF(PRESSURE_LEVEL.GT.PRESSURE_TEST)THEN COFTHQ1C.234
COFTHQ1C.235
DO I=START_POINT_NO_HALO-ROW_LENGTH,END_P_POINT_NO_HALO COFTHQ1C.236
IF((PRESSURE(I+ROW_LENGTH,LEVEL_P).GT.PRESSURE(I,LEVEL_P-1)).OR. COFTHQ1C.237
& (PRESSURE(I+ROW_LENGTH,LEVEL_P).LT. COFTHQ1C.238
& PRESSURE(I,LEVEL_P+1)))THEN COFTHQ1C.239
DIFFUSION_NS(I,LEVEL)=0.0 COFTHQ1C.240
ENDIF COFTHQ1C.241
END DO COFTHQ1C.242
COFTHQ1C.243
ENDIF COFTHQ1C.244
ENDDO COFTHQ1C.245
COFTHQ1C.246
*IF DEF,MPP COFTHQ1C.247
CALL SWAPBOUNDS(DIFFUSION_EW,ROW_LENGTH,tot_P_ROWS, COFTHQ1C.248
& EW_Halo,NS_Halo,P_LEVELS) COFTHQ1C.249
CALL SWAPBOUNDS(DIFFUSION_NS,ROW_LENGTH,tot_P_ROWS, COFTHQ1C.250
& EW_Halo,NS_Halo,P_LEVELS) COFTHQ1C.251
*ENDIF COFTHQ1C.252
COFTHQ1C.253
CL END OF ROUTINE COEFF_TH_Q COFTHQ1C.254
COFTHQ1C.255
RETURN COFTHQ1C.256
END COFTHQ1C.257
*ENDIF COFTHQ1C.258