*IF DEF,A05_2A,OR,DEF,A05_2C,OR,DEF,A05_3B,OR,DEF,A05_3C AJX1F405.149
C ******************************COPYRIGHT****************************** GTS2F400.10261
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10262
C GTS2F400.10263
C Use, duplication or disclosure of this code is subject to the GTS2F400.10264
C restrictions as set forth in the contract. GTS2F400.10265
C GTS2F400.10266
C Meteorological Office GTS2F400.10267
C London Road GTS2F400.10268
C BRACKNELL GTS2F400.10269
C Berkshire UK GTS2F400.10270
C RG12 2SZ GTS2F400.10271
C GTS2F400.10272
C If no contract has been raised with this copy of the code, the use, GTS2F400.10273
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10274
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10275
C Modelling at the above address. GTS2F400.10276
C ******************************COPYRIGHT****************************** GTS2F400.10277
C GTS2F400.10278
CLL SUBROUTINE THP_DET------------------------------------------------ THPDET1A.3
CLL THPDET1A.4
CLL SUITABLE FOR SINGLE COLUMN MODEL USE THPDET1A.5
CLL THPDET1A.6
CLL CODE REWORKED FOR CRAY Y-MP BY D.GREGORY AUTUMN/WINTER 1989/90 THPDET1A.7
CLL THPDET1A.8
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: THPDET1A.9
CLL VERSION DATE THPDET1A.10
CLL THPDET1A.11
CLL PROGRAMMING STANDARDS : UNIFIED MODEL DOCUMENTATION PAPER NO. 4 THPDET1A.12
CLL VERSION NO. 1 THPDET1A.13
CLL THPDET1A.14
CLL LOGICAL COMPONENTS COVERED : P27 THPDET1A.15
CLL THPDET1A.16
CLL PURPOSE : CALCULATES POTENTIAL TEMPERATURE OF THE THPDET1A.17
CLL PARCEL IN LAYER K+1 AFTER FORCED DETRAINMENT THPDET1A.18
CLL IN LAYER K THPDET1A.19
CLL THPDET1A.20
CLL DOCUMENTATION : UNIFIED MODEL DOCUMENTATION PAPER P27 THPDET1A.21
CLL SECTION (6), EQUATION (28) THPDET1A.22
CLL THPDET1A.23
CLLEND----------------------------------------------------------------- THPDET1A.24
C THPDET1A.25
C*L ARGUMENTS--------------------------------------------------------- THPDET1A.26
C THPDET1A.27
SUBROUTINE THP_DET (NPNTS,THPKP1,THEKP1,QPKP1,QEKP1,QSEKP1, 3THPDET1A.28
* DQSKP1,BGMKP1,BCALC) THPDET1A.29
C THPDET1A.30
IMPLICIT NONE THPDET1A.31
C THPDET1A.32
C----------------------------------------------------------------------- THPDET1A.33
C MODEL CONSTANTS THPDET1A.34
C----------------------------------------------------------------------- THPDET1A.35
C THPDET1A.36
*CALL C_EPSLON 
THPDET1A.37
*CALL XSBMIN THPDET1A.38
C THPDET1A.39
C----------------------------------------------------------------------- THPDET1A.40
C VECTOR LENGTHS AND LOOP COUNTERS THPDET1A.41
C----------------------------------------------------------------------- THPDET1A.42
C THPDET1A.43
INTEGER NPNTS ! IN VECTOR LENGTH THPDET1A.44
C THPDET1A.45
INTEGER I ! LOOP COUNTER THPDET1A.46
C THPDET1A.47
C THPDET1A.48
C----------------------------------------------------------------------- THPDET1A.49
C VARAIBLES WHICH ARE INPUT THPDET1A.50
C----------------------------------------------------------------------- THPDET1A.51
C THPDET1A.52
REAL THEKP1(NPNTS) ! IN ENVIRONMENT POTENTIAL TEMPERATURE THPDET1A.53
! IN LAYER K+1 (K) THPDET1A.54
C THPDET1A.55
REAL QPKP1(NPNTS) ! IN PARCEL MIXING RATIO IN LAYER K+1 THPDET1A.56
! (KG/KG) THPDET1A.57
C THPDET1A.58
REAL QSEKP1(NPNTS) ! IN ENVIRONMENT SATURATED MIXING RATIO THPDET1A.59
! IN LAYER K+1 (KG/KG) THPDET1A.60
C THPDET1A.61
REAL DQSKP1(NPNTS) ! IN GRADIENT OF SATURATION MIXING RATIO THPDET1A.62
! POTENTIAL TEMPERATURE FOR THE THPDET1A.63
! ENVIRONMENT IN LAYER K+1 (KG/KG/K) THPDET1A.64
C THPDET1A.65
REAL QEKP1(NPNTS) ! IN ENVIRONMENT MIXING RATIO IN THPDET1A.66
! LAYER K+1 (KG/KG) THPDET1A.67
C THPDET1A.68
LOGICAL BGMKP1(NPNTS) ! IN MASK FOR PARCELS WHICH ARE SATURATED THPDET1A.69
! IN LAYER K+1 THPDET1A.70
C THPDET1A.71
LOGICAL BCALC(NPNTS) ! IN MASK FOR PARCELS AT WHICH THPDET1A.72
! CALCULATIONS OF THIS SUBROUTINE ARE THPDET1A.73
! TO BE CARRIED OUT THPDET1A.74
C THPDET1A.75
C THPDET1A.76
C----------------------------------------------------------------------- THPDET1A.77
C VARAIBLES WHICH ARE OUTPUT THPDET1A.78
C----------------------------------------------------------------------- THPDET1A.79
C THPDET1A.80
REAL THPKP1(NPNTS) ! OUT PARCEL POTENTIAL TEMPERATURE THPDET1A.81
! IN LAYER K+1 AFTER FORCED THPDET1A.82
! DETRAINMENT (K) THPDET1A.83
C THPDET1A.84
C*--------------------------------------------------------------------- THPDET1A.85
CL THPDET1A.86
CL--------------------------------------------------------------------- THPDET1A.87
CL NO SIGNIFICANT STRUCTURE THPDET1A.88
CL--------------------------------------------------------------------- THPDET1A.89
CL THPDET1A.90
C THPDET1A.91
DO 10 I=1,NPNTS THPDET1A.92
IF (BCALC(I))THEN THPDET1A.93
IF (BGMKP1(I)) THEN THPDET1A.94
THPKP1(I) = THEKP1(I) + THPDET1A.95
* (C_VIRTUAL*THEKP1(I)* THPDET1A.96
* (QEKP1(I)-QSEKP1(I)) + XSBMIN) THPDET1A.97
* /( 1. + C_VIRTUAL*THEKP1(I)*DQSKP1(I) ) THPDET1A.98
C THPDET1A.99
ELSE THPDET1A.100
THPKP1(I) = (THEKP1(I)*(1. + C_VIRTUAL*QEKP1(I)) THPDET1A.101
* + XSBMIN) THPDET1A.102
* /(1. + C_VIRTUAL*QPKP1(I)) THPDET1A.103
END IF THPDET1A.104
END IF THPDET1A.105
10 CONTINUE THPDET1A.106
C THPDET1A.107
RETURN THPDET1A.108
END THPDET1A.109
*ENDIF THPDET1A.110