*IF DEF,A03_6A BOUYTQ6A.2
C *****************************COPYRIGHT****************************** BOUYTQ6A.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. BOUYTQ6A.4
C BOUYTQ6A.5
C Use, duplication or disclosure of this code is subject to the BOUYTQ6A.6
C restrictions as set forth in the contract. BOUYTQ6A.7
C BOUYTQ6A.8
C Meteorological Office BOUYTQ6A.9
C London Road BOUYTQ6A.10
C BRACKNELL BOUYTQ6A.11
C Berkshire UK BOUYTQ6A.12
C RG12 2SZ BOUYTQ6A.13
C BOUYTQ6A.14
C If no contract has been raised with this copy of the code, the use, BOUYTQ6A.15
C duplication or disclosure of it is strictly prohibited. Permission BOUYTQ6A.16
C to do so must first be obtained in writing from the Head of Numerical BOUYTQ6A.17
C Modelling at the above address. BOUYTQ6A.18
C ******************************COPYRIGHT****************************** BOUYTQ6A.19
! BOUYTQ6A.20
! SUBROUTINE BOUY_TQ BOUYTQ6A.21
BOUYTQ6A.22
! PURPOSE: To calculate buoyancy parameters on p,T,q-levels BOUYTQ6A.23
! BOUYTQ6A.24
! METHOD: BOUYTQ6A.25
! BOUYTQ6A.26
! ORIGINAL PROGRAMMER: J. James BOUYTQ6A.27
! CURRENT CODE OWNER: R.N.B. Smith BOUYTQ6A.28
! BOUYTQ6A.29
! HISTORY: BOUYTQ6A.30
! DATE VERSION COMMENT BOUYTQ6A.31
! ---- ------- ------- BOUYTQ6A.32
! new deck BOUYTQ6A.33
!!! 4.5 Jul. 98 Kill the IBM specific lines. (JCThil) AJC1F405.310
! BOUYTQ6A.34
! CODE DESCRIPTION: BOUYTQ6A.35
! LANGUAGE: FORTRAN 77 + CRAY EXTENSIONS BOUYTQ6A.36
! THIS CODE IS WRITTEN TO UMDP3 PROGRAMMING STANDARDS. BOUYTQ6A.37
! BOUYTQ6A.38
BOUYTQ6A.39
BOUYTQ6A.40
BOUYTQ6A.41
SUBROUTINE BOUY_TQ ( 2,7BOUYTQ6A.42
& P_FIELD,P1,P_POINTS,BL_LEVELS BOUYTQ6A.43
&,P,T,Q,QCF,QCL BOUYTQ6A.44
&,BT,BQ,BT_CLD,BQ_CLD,A_QS,A_DQSDT,DQSDT BOUYTQ6A.45
&,LTIMER BOUYTQ6A.46
& ) BOUYTQ6A.47
BOUYTQ6A.48
IMPLICIT NONE BOUYTQ6A.49
BOUYTQ6A.50
! ARGUMENTS WITH INTENT IN. IE: INPUT VARIABLES. BOUYTQ6A.51
BOUYTQ6A.52
LOGICAL LTIMER ! IN Flag for TIMER diagnostics BOUYTQ6A.53
BOUYTQ6A.54
INTEGER BOUYTQ6A.55
& P_FIELD ! IN No. of P-grid points in whole field. BOUYTQ6A.56
&,P1 ! IN First P-grid point to be processed. BOUYTQ6A.57
&,P_POINTS ! IN No. of P-grid points to be processed. BOUYTQ6A.61
&,BL_LEVELS ! IN No. of atmospheric levels for which BOUYTQ6A.65
! boundary layer fluxes are calculated. BOUYTQ6A.66
! Assumed <=30 for dimensioning GAMMA() BOUYTQ6A.67
! in common deck C_GAMMA BOUYTQ6A.68
BOUYTQ6A.69
REAL BOUYTQ6A.70
& P(P_FIELD,BL_LEVELS) ! IN Pressure at pressure points. BOUYTQ6A.71
&,T(P_FIELD,BL_LEVELS) ! IN Temperature (K). At P points BOUYTQ6A.72
&,Q(P_FIELD,BL_LEVELS) ! IN Sp humidity (kg water per kg air). BOUYTQ6A.73
&,QCL(P_FIELD,BL_LEVELS) ! IN Cloud liq water (kg per kg air). BOUYTQ6A.74
&,QCF(P_FIELD,BL_LEVELS) ! IN Cloud liq water (kg per kg air). BOUYTQ6A.75
BOUYTQ6A.76
BOUYTQ6A.77
! ARGUMENTS WITH INTENT OUT. IE: OUTPUT VARIABLES. BOUYTQ6A.78
BOUYTQ6A.79
REAL BOUYTQ6A.80
& BQ(P_FIELD,BL_LEVELS) ! OUT A buoyancy parameter for clear air BOUYTQ6A.81
&,BT(P_FIELD,BL_LEVELS) ! OUT A buoyancy parameter for clear air BOUYTQ6A.82
&,BQ_CLD(P_FIELD,BL_LEVELS) BOUYTQ6A.83
! ! OUT A buoyancy parameter for cloudy air BOUYTQ6A.84
&,BT_CLD(P_FIELD,BL_LEVELS) BOUYTQ6A.85
! ! OUT A buoyancy parameter for cloudy air BOUYTQ6A.86
&,A_QS(P_FIELD,BL_LEVELS) BOUYTQ6A.87
! ! OUT Saturated lapse rate factor BOUYTQ6A.88
&,A_DQSDT(P_FIELD,BL_LEVELS) BOUYTQ6A.89
! ! OUT Saturated lapse rate factor BOUYTQ6A.90
&,DQSDT(P_FIELD,BL_LEVELS) BOUYTQ6A.91
! ! OUT Derivative of q_SAT w.r.t. T BOUYTQ6A.92
BOUYTQ6A.93
! LOCAL VARIABLES. BOUYTQ6A.94
BOUYTQ6A.95
REAL BOUYTQ6A.96
& QS(P_FIELD) ! WORK Saturated mixing ratio. BOUYTQ6A.97
BOUYTQ6A.98
INTEGER BOUYTQ6A.99
& I BOUYTQ6A.100
&, K BOUYTQ6A.101
BOUYTQ6A.102
REAL BOUYTQ6A.103
& BC BOUYTQ6A.104
BOUYTQ6A.105
EXTERNAL BOUYTQ6A.106
& QSAT,TIMER BOUYTQ6A.107
BOUYTQ6A.108
*CALL C_0_DG_C 
BOUYTQ6A.109
*CALL C_LHEAT BOUYTQ6A.110
*CALL C_G BOUYTQ6A.111
*CALL C_R_CP BOUYTQ6A.112
*CALL C_EPSLON BOUYTQ6A.113
*CALL C_VKMAN BOUYTQ6A.114
*CALL C_SOILH BOUYTQ6A.115
*CALL C_MDI BOUYTQ6A.116
BOUYTQ6A.117
BOUYTQ6A.118
REAL ETAR,GRCP,LCRCP,LFRCP,LS,LSRCP BOUYTQ6A.119
PARAMETER ( BOUYTQ6A.120
& ETAR=1.0/(1.0-EPSILON) ! Used in buoyancy parameter BETAC. BOUYTQ6A.121
&,GRCP=G/CP ! Used in DZTL, FTL calculations. BOUYTQ6A.122
&,LCRCP=LC/CP ! Latent heat of condensation / CP. BOUYTQ6A.123
&,LFRCP=LF/CP ! Latent heat of fusion / CP. BOUYTQ6A.124
&,LS=LC+LF ! Latent heat of sublimation. BOUYTQ6A.125
&,LSRCP=LS/CP ! Latent heat of sublimation / CP. BOUYTQ6A.126
&) BOUYTQ6A.127
BOUYTQ6A.128
IF (LTIMER) THEN BOUYTQ6A.129
CALL TIMER('BOUY_TQ ',3) BOUYTQ6A.130
ENDIF BOUYTQ6A.131
!----------------------------------------------------------------------- BOUYTQ6A.132
!! 1. Loop round levels. BOUYTQ6A.133
!----------------------------------------------------------------------- BOUYTQ6A.134
DO K=1,BL_LEVELS BOUYTQ6A.135
!----------------------------------------------------------------------- BOUYTQ6A.136
!! 1.1 Calculate saturated specific humidity at pressure and BOUYTQ6A.137
!! temperature of current level. BOUYTQ6A.138
!----------------------------------------------------------------------- BOUYTQ6A.139
CALL QSAT(QS(P1),T(P1,K),P(P1,K),P_POINTS) BOUYTQ6A.140
! BOUYTQ6A.141
DO I=P1,P1+P_POINTS-1 BOUYTQ6A.142
BOUYTQ6A.143
!----------------------------------------------------------------------- BOUYTQ6A.144
!! 1.2 Calculate buoyancy parameters BT and BQ, required for the BOUYTQ6A.145
!! calculation of stability. BOUYTQ6A.146
!----------------------------------------------------------------------- BOUYTQ6A.147
BOUYTQ6A.148
BT(I,K) = 1.0/T(I,K) BOUYTQ6A.149
BQ(I,K) = C_VIRTUAL/(1.0+C_VIRTUAL*Q(I,K)-QCL(I,K)-QCF(I,K)) BOUYTQ6A.150
! BOUYTQ6A.151
IF (T(I,K) .GT. TM) THEN BOUYTQ6A.152
DQSDT(I,K) = (EPSILON * LC * QS(I)) BOUYTQ6A.153
& / ( R * T(I,K) * T(I,K) ) BOUYTQ6A.154
! ... (Clausius-Clapeyron) for T above freezing BOUYTQ6A.155
! BOUYTQ6A.156
A_QS(I,K) = 1.0 / (1.0 + LCRCP*DQSDT(I,K)) BOUYTQ6A.157
! BOUYTQ6A.158
A_DQSDT(I,K) = A_QS(I,K) * DQSDT(I,K) BOUYTQ6A.159
! BOUYTQ6A.160
BC = LCRCP*BT(I,K) - ETAR*BQ(I,K) BOUYTQ6A.161
! BOUYTQ6A.162
ELSE BOUYTQ6A.163
DQSDT(I,K) = (EPSILON * LS * QS(I)) BOUYTQ6A.164
& / ( R * T(I,K) * T(I,K) ) BOUYTQ6A.165
! ... (Clausius-Clapeyron) for T below freezing BOUYTQ6A.166
! BOUYTQ6A.167
A_QS(I,K) = 1.0 / (1.0 + LSRCP*DQSDT(I,K)) BOUYTQ6A.168
! BOUYTQ6A.169
A_DQSDT(I,K) = A_QS(I,K) * DQSDT(I,K) BOUYTQ6A.170
! BOUYTQ6A.171
BC = LSRCP*BT(I,K) - ETAR*BQ(I,K) BOUYTQ6A.172
! BOUYTQ6A.173
ENDIF BOUYTQ6A.174
! BOUYTQ6A.175
!----------------------------------------------------------------------- BOUYTQ6A.176
!! 1.3 Calculate in-cloud buoyancy parameters. BOUYTQ6A.177
!----------------------------------------------------------------------- BOUYTQ6A.178
! BOUYTQ6A.179
BT_CLD(I,K) = BT(I,K) - A_DQSDT(I,K) * BC BOUYTQ6A.180
BQ_CLD(I,K) = BQ(I,K) + A_QS(I,K) * BC BOUYTQ6A.181
! BOUYTQ6A.182
ENDDO ! p_points BOUYTQ6A.183
ENDDO ! bl_levels BOUYTQ6A.184
BOUYTQ6A.185
IF (LTIMER) THEN BOUYTQ6A.186
CALL TIMER('BOUY_TQ ',4) BOUYTQ6A.187
ENDIF BOUYTQ6A.188
RETURN BOUYTQ6A.189
END BOUYTQ6A.190
*ENDIF BOUYTQ6A.191