*IF DEF,A05_2A,OR,DEF,A05_2C,OR,DEF,A05_3B,OR,DEF,A05_3C AJX1F405.123
C ******************************COPYRIGHT****************************** GTS2F400.1441
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.1442
C GTS2F400.1443
C Use, duplication or disclosure of this code is subject to the GTS2F400.1444
C restrictions as set forth in the contract. GTS2F400.1445
C GTS2F400.1446
C Meteorological Office GTS2F400.1447
C London Road GTS2F400.1448
C BRACKNELL GTS2F400.1449
C Berkshire UK GTS2F400.1450
C RG12 2SZ GTS2F400.1451
C GTS2F400.1452
C If no contract has been raised with this copy of the code, the use, GTS2F400.1453
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.1454
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.1455
C Modelling at the above address. GTS2F400.1456
C ******************************COPYRIGHT****************************** GTS2F400.1457
C GTS2F400.1458
CLL SUBROUTINE COR_ENGY----------------------------------------------- CORENG1A.3
CLL CORENG1A.4
CLL PURPOSE : TO ADJUST THE POTENTIAL TEMPERATURE INCREMENTS CORENG1A.5
CLL TO ENSURE THE CONSERVATION OF MOIST STATIC ENERGY CORENG1A.6
CLL CORENG1A.7
CLL SUITABLE FOR SINGLE COLUMN MODEL USE CORENG1A.8
CLL CORENG1A.9
CLL CODE REWORKED FOR CRAY Y-MP BY D.GREGORY AUTUMN/WINTER 1989/90 CORENG1A.10
CLL CORENG1A.11
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: CORENG1A.12
CLL VERSION DATE CORENG1A.13
CLL 4.5 22/7/98 Kill the IBM specific lines (JCThil) AJC1F405.3
CLL CORENG1A.14
CLL PROGRAMMING STANDARDS : UNIFIED MODEL DOCUMENTATION PAPER NO. 4 CORENG1A.15
CLL VERSION NO. 1 CORENG1A.16
CLL CORENG1A.17
CLL LOGICAL COMPONENTS COVERED: CORENG1A.18
CLL CORENG1A.19
CLL SYSTEM TASK : P27 CORENG1A.20
CLL CORENG1A.21
CLL DOCUMENTATION : UNIFIED MODEL DOCUMENTATION PAPER P27 CORENG1A.22
CLL SECTION (12) CORENG1A.23
CLL CORENG1A.24
CLLEND----------------------------------------------------------------- CORENG1A.25
C CORENG1A.26
C*L ARGUMENTS--------------------------------------------------------- CORENG1A.27
C CORENG1A.28
SUBROUTINE COR_ENGY 4GSS1F403.162
* (NP_FIELD,NPNTS,NCORE,NLEV,DTHBYDT,DQBYDT,SNOW, GSS1F403.163
* EXNER,PSTAR,DELAK,DELBK,AKH,BKH,INDEX4) GSS1F403.164
C CORENG1A.31
IMPLICIT NONE CORENG1A.32
C CORENG1A.33
C CORENG1A.34
C---------------------------------------------------------------------- CORENG1A.35
C MODEL CONSTANTS CORENG1A.36
C---------------------------------------------------------------------- CORENG1A.37
C CORENG1A.38
*CALL C_R_CP 
CORENG1A.39
*CALL C_G CORENG1A.40
*CALL C_LHEAT CORENG1A.41
C CORENG1A.42
C---------------------------------------------------------------------- CORENG1A.43
C VECTOR LENGTH AND LOOP COUNTERS CORENG1A.44
C---------------------------------------------------------------------- CORENG1A.45
C CORENG1A.46
INTEGER NP_FIELD ! LENGTH OF DATA (ALSO USED TO GSS1F403.165
! SPECIFY STARTING POINT OF GSS1F403.166
! DATA PASSED IN) GSS1F403.167
C GSS1F403.168
INTEGER NCORE ! IN VECTOR LENGTHS CORENG1A.50
C CORENG1A.51
INTEGER NPNTS ! IN FULL VECTOR LENGTH CORENG1A.52
C CORENG1A.53
INTEGER NLEV ! IN NUMBER OF MODEL LAYERS CORENG1A.54
C CORENG1A.55
INTEGER I,K ! LOOP COUNTERS CORENG1A.56
C CORENG1A.57
C CORENG1A.58
C---------------------------------------------------------------------- CORENG1A.59
C VARIABLES WHICH ARE INPUT CORENG1A.60
C---------------------------------------------------------------------- CORENG1A.61
C CORENG1A.62
INTEGER INDEX4(NPNTS) GSS1F403.169
REAL DQBYDT(NP_FIELD,NLEV) ! IN INCREMENT TO MODEL MIXING GSS1F403.170
! RATIO DUE TO CONVECTION CORENG1A.64
! (KG/KG/S) CORENG1A.65
C CORENG1A.66
REAL SNOW(NP_FIELD) ! IN SNOW AT SURFACE (KG/M**2/S) GSS1F403.171
C CORENG1A.68
REAL EXNER(NP_FIELD,NLEV+1) ! IN EXNER RATIO GSS1F403.172
C CORENG1A.70
REAL PSTAR(NP_FIELD) ! IN SURFACE PRESSURE (PA) GSS1F403.173
C CORENG1A.72
REAL DELAK(NLEV), ! IN DIFFERENCE IN HYBRID CO-ORDINATE CORENG1A.73
* DELBK(NLEV) ! COEFFICIENTS A AND B CORENG1A.74
! ACROSS LAYER K CORENG1A.75
C CORENG1A.76
REAL AKH(NLEV+1) ! IN Hybrid coordinate A at CORENG1A.77
! layer boundary CORENG1A.78
REAL BKH(NLEV+1) ! IN Hybrid coordinate B at CORENG1A.79
! layer boundary CORENG1A.80
C CORENG1A.81
C---------------------------------------------------------------------- CORENG1A.82
C VARIABLES WHICH ARE INPUT AND OUTPUT CORENG1A.83
C---------------------------------------------------------------------- CORENG1A.84
C CORENG1A.85
REAL DTHBYDT(NP_FIELD,NLEV) ! INOUT GSS1F403.174
! IN INCREMENT TO MODEL POTENTIAL CORENG1A.87
! TEMPERATURE DUE TO CONVECTION CORENG1A.88
! (K/S) CORENG1A.89
! OUT CORRECTED INCREMENT TO MODEL CORENG1A.90
! POTENTIAL TEMPERATURE DUE TO CORENG1A.91
! CONVECTION (K/S) CORENG1A.92
C CORENG1A.93
C CORENG1A.94
C---------------------------------------------------------------------- CORENG1A.95
C VARIABLES WHICH ARE LOCALLY DEFINED CORENG1A.96
C CORENG1A.97
REAL QSUM(NCORE) ! SUMMATION OF INCREMENTS TO MODEL CORENG1A.137
! MIXING RATIO DUE TO CONVECTION CORENG1A.138
! IN THE VERTICAL, WEIGHTED CORENG1A.139
! ACCORDING TO THE MASS OF THE CORENG1A.140
! LAYER (KG/M**2/S) CORENG1A.141
C CORENG1A.142
REAL TSPOS(NCORE) ! SUMMATION OF POSITIVE INCREMENTS CORENG1A.143
! TO MODEL POTENTIAL TEMPERATURE CORENG1A.144
! DUE TO CONVECTION WITH HEIGHT, CORENG1A.145
! WEIGHTED ACCORDING TO THE MASS CORENG1A.146
! OF THE LAYER (K/M**2/S) CORENG1A.147
C CORENG1A.148
REAL TSNEG(NCORE) ! SUMMATION OF NEGATIVE INCREMENTS CORENG1A.149
! TO MODEL POTENTIAL TEMPERATURE CORENG1A.150
! DUE TO CONVECTION WITH HEIGHT, CORENG1A.151
! WEIGHTED ACCORDING TO THE MASS CORENG1A.152
! OF THE LAYER (K/M**2/S) CORENG1A.153
C CORENG1A.154
REAL TERR(NCORE) ! SUMMATION OF ALL INCREMENTS TO CORENG1A.155
! MODEL POTENTIAL TEMPERATURE CORENG1A.156
! DUE TO CONVECTION WITH HEIGHT, CORENG1A.157
! WEIGHTED ACCORDING TO THE MASS CORENG1A.158
! OF THE LAYER (K/M**2/S) CORENG1A.159
C CORENG1A.160
LOGICAL BPOSER(NCORE) ! MASK FOR POINTS IN LAYER K AT WHICH CORENG1A.161
! INCREMENTS TO MODEL POTENTIAL CORENG1A.162
! TEMPERATURE DUE TO CONVECTION ARE CORENG1A.163
! POSITIVE CORENG1A.164
C CORENG1A.165
LOGICAL BCORR(NCORE) ! MASK FOR POINTS AT WHICH ENTHALPY CORENG1A.166
! CORRECTION IS NECESSARY CORENG1A.167
C CORENG1A.168
REAL DELPK ! DIFFERENCE IN PRESSURE ACROSS A CORENG1A.170
! LAYER (PA) CORENG1A.171
C CORENG1A.172
REAL EXTEMPK ! EXNER RATIO AT THE MID-POINT OF CORENG1A.173
! LAYER K CORENG1A.174
C CORENG1A.175
CORENG1A.176
REAL CORENG1A.177
& PU,PL CORENG1A.178
*CALL P_EXNERC CORENG1A.179
CORENG1A.180
C*---------------------------------------------------------------------- CORENG1A.181
CL CORENG1A.182
CL---------------------------------------------------------------------- CORENG1A.183
CL SUM UP MIXING RATIO AND +VE AND -VE TEMPERATURE INCREMENTS CORENG1A.184
CL---------------------------------------------------------------------- CORENG1A.185
CL CORENG1A.186
DO 20 I=1,NCORE CORENG1A.187
QSUM (I) = 0.0 CORENG1A.188
TSPOS(I) = 0.0 CORENG1A.189
TSNEG(I) = 0.0 CORENG1A.190
20 CONTINUE CORENG1A.191
C CORENG1A.192
DO 40 K=1,NLEV CORENG1A.193
DO 30 I=1,NCORE CORENG1A.194
C CORENG1A.195
DELPK = -DELAK(K) - DELBK(K)*PSTAR(INDEX4(I)) GSS1F403.175
C CORENG1A.197
PU=PSTAR(INDEX4(I))*BKH(K+1) + AKH(K+1) GSS1F403.176
PL=PSTAR(INDEX4(I))*BKH(K) + AKH(K) GSS1F403.177
EXTEMPK = GSS1F403.178
& P_EXNER_C(EXNER(INDEX4(I),K+1), GSS1F403.179
& EXNER(INDEX4(I),K),PU,PL,KAPPA) GSS1F403.180
C CORENG1A.201
QSUM(I) = QSUM(I) + DQBYDT(INDEX4(I),K)*DELPK GSS1F403.181
C CORENG1A.203
IF (DTHBYDT(INDEX4(I),K) .GT. 0.0) THEN GSS1F403.182
TSPOS(I) = TSPOS(I) + GSS1F403.183
& DTHBYDT(INDEX4(I),K)*(CP*DELPK*EXTEMPK) GSS1F403.184
ELSE CORENG1A.206
TSNEG(I) = TSNEG(I) + GSS1F403.185
& DTHBYDT(INDEX4(I),K)*(CP*DELPK*EXTEMPK) GSS1F403.186
ENDIF CORENG1A.208
30 CONTINUE CORENG1A.209
40 CONTINUE CORENG1A.210
CL CORENG1A.211
CL---------------------------------------------------------------------- CORENG1A.212
CL CALCULATE THE ERROR AND APPLY THE NECESSARY CORRECTION CORENG1A.213
CL CORENG1A.214
CL UM DOCUMENTATION PAPER P27 CORENG1A.215
CL SECTION (12), EQUATION (48), (49) CORENG1A.216
CL---------------------------------------------------------------------- CORENG1A.217
CL CORENG1A.218
DO 50 I=1,NCORE CORENG1A.219
C CORENG1A.220
TERR(I) = LC*QSUM(I) - LF*G*SNOW(INDEX4(I)) + GSS1F403.187
& TSPOS(I) + TSNEG(I) GSS1F403.188
C CORENG1A.222
BPOSER(I) = TERR(I) .GT. 0.0 CORENG1A.223
C CORENG1A.224
IF (BPOSER(I) .AND. (TSPOS(I) .EQ. 0.0)) THEN CORENG1A.225
BPOSER(I) = .FALSE. CORENG1A.226
ELSE IF (.NOT.BPOSER(I) .AND. (TSNEG(I) .EQ. 0.0)) THEN CORENG1A.227
BPOSER(I) = .TRUE. CORENG1A.228
ENDIF CORENG1A.229
C CORENG1A.230
BCORR(I) = (TSPOS(I) .NE. 0.0) .OR. (TSNEG(I) .NE. 0.0) CORENG1A.231
C CORENG1A.232
IF (BPOSER(I) .AND. BCORR(I)) THEN CORENG1A.233
TERR(I) = 1. - TERR(I)/TSPOS(I) CORENG1A.234
ELSE IF (.NOT.BPOSER(I) .AND. BCORR(I)) THEN CORENG1A.235
TERR(I) = 1. - TERR(I)/TSNEG(I) CORENG1A.236
ENDIF CORENG1A.237
C CORENG1A.238
50 CONTINUE CORENG1A.239
C CORENG1A.240
DO 100 K=1,NLEV CORENG1A.241
CDIR$ IVDEP CORENG1A.242
! Fujitsu vectorization directive GRB0F405.215
!OCL NOVREC GRB0F405.216
DO 100 I=1,NCORE CORENG1A.243
IF (BCORR(I) .AND. (( BPOSER(I) .AND. CORENG1A.244
* (DTHBYDT(INDEX4(I),K) .GT. 0.0)) .OR. ( .NOT.BPOSER(I) GSS1F403.189
* .AND. (DTHBYDT(INDEX4(I),K) .LT. 0.0)))) GSS1F403.190
* DTHBYDT(INDEX4(I),K) = DTHBYDT(INDEX4(I),K)*TERR(I) GSS1F403.191
100 CONTINUE CORENG1A.248
C CORENG1A.249
RETURN CORENG1A.250
END CORENG1A.251
*ENDIF CORENG1A.252