*IF DEF,A03_7A ACB1F405.1
C *****************************COPYRIGHT****************************** BOUYTQ5B.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. BOUYTQ5B.4
C BOUYTQ5B.5
C Use, duplication or disclosure of this code is subject to the BOUYTQ5B.6
C restrictions as set forth in the contract. BOUYTQ5B.7
C BOUYTQ5B.8
C Meteorological Office BOUYTQ5B.9
C London Road BOUYTQ5B.10
C BRACKNELL BOUYTQ5B.11
C Berkshire UK BOUYTQ5B.12
C RG12 2SZ BOUYTQ5B.13
C BOUYTQ5B.14
C If no contract has been raised with this copy of the code, the use, BOUYTQ5B.15
C duplication or disclosure of it is strictly prohibited. Permission BOUYTQ5B.16
C to do so must first be obtained in writing from the Head of Numerical BOUYTQ5B.17
C Modelling at the above address. BOUYTQ5B.18
C ******************************COPYRIGHT****************************** BOUYTQ5B.19
! BOUYTQ5B.20
! SUBROUTINE BOUY_TQ BOUYTQ5B.21
BOUYTQ5B.22
! PURPOSE: To calculate buoyancy parameters BT and BQ BOUYTQ5B.23
! BOUYTQ5B.24
! METHOD: BOUYTQ5B.25
! BOUYTQ5B.26
! ORIGINAL PROGRAMMER: J James BOUYTQ5B.27
! CURRENT CODE OWNER: RNB Smith BOUYTQ5B.28
! BOUYTQ5B.29
! HISTORY: BOUYTQ5B.30
! DATE VERSION COMMENT BOUYTQ5B.31
! ---- ------- ------- BOUYTQ5B.32
! new deck BOUYTQ5B.33
! 4.4 29/10/97 K loops extended to give surface buoyancy parameters ARE1F404.108
! R. Essery ARE1F404.109
! 8/9/97 4.4 L_BL_LSPICE specifies mixed phase precipitation ADM3F404.357
! scheme D.Wilson ADM3F404.358
! 4.5 Jul. 98 Kill the IBM specific lines. (JCThil) AJC1F405.311
! BOUYTQ5B.34
! CODE DESCRIPTION: BOUYTQ5B.35
! LANGUAGE: FORTRAN 77 + CRAY EXTENSIONS BOUYTQ5B.36
! THIS CODE IS WRITTEN TO UMDP3 PROGRAMMING STANDARDS. BOUYTQ5B.37
! BOUYTQ5B.38
! SYSTEM COMPONENT COVERED: ?? BOUYTQ5B.39
! SYSTEM TASK: ?? BOUYTQ5B.40
BOUYTQ5B.41
BOUYTQ5B.42
BOUYTQ5B.43
SUBROUTINE BOUY_TQ ( 2,7BOUYTQ5B.44
& P_FIELD,P1 BOUYTQ5B.45
&,P_POINTS,BL_LEVELS,P BOUYTQ5B.46
&,CF,Q,QCF,QCL,T BOUYTQ5B.47
&,TL,BT,BQ,BF ADM3F404.359
&,L_BL_LSPICE,LTIMER ADM3F404.360
& ) BOUYTQ5B.50
BOUYTQ5B.51
IMPLICIT NONE BOUYTQ5B.52
BOUYTQ5B.53
! ARGUMENTS WITH INTENT IN. IE: INPUT VARIABLES. BOUYTQ5B.54
BOUYTQ5B.55
LOGICAL LTIMER ! IN Flag for TIMER diagnostics BOUYTQ5B.56
&, L_BL_LSPICE !IN ADM3F404.361
! TRUE Use scientific treatment of mixed ADM3F404.362
! phase precip scheme. ADM3F404.363
! FALSE Do not use mixed phase precip ADM3F404.364
! considerations ADM3F404.365
BOUYTQ5B.57
INTEGER BOUYTQ5B.58
& P_FIELD ! IN No. of P-grid points in whole field. BOUYTQ5B.59
&,P1 ! IN First P-grid point to be processed. BOUYTQ5B.60
&,P_POINTS ! IN No. of P-grid points to be processed. BOUYTQ5B.61
&,BL_LEVELS ! IN No. of atmospheric levels for which BOUYTQ5B.68
! boundary layer fluxes are calculated. BOUYTQ5B.69
! Assumed <=30 for dimensioning GAMMA() BOUYTQ5B.70
! in common deck C_GAMMA BOUYTQ5B.71
BOUYTQ5B.72
REAL BOUYTQ5B.73
& P(P_FIELD,BL_LEVELS) ! IN Pressure at pressure points. BOUYTQ5B.74
&,T(P_FIELD,BL_LEVELS) ! IN Temperature (K). At P points BOUYTQ5B.75
&,TL(P_FIELD,BL_LEVELS) ! IN Liquid/frozen water temperature BOUYTQ5B.76
&,Q(P_FIELD,BL_LEVELS) ! IN Sp humidity (kg water per kg air). BOUYTQ5B.77
&,QCL(P_FIELD,BL_LEVELS) ! IN Cloud liq water (kg per kg air). BOUYTQ5B.78
&,QCF(P_FIELD,BL_LEVELS) ! IN Cloud liq water (kg per kg air). BOUYTQ5B.79
&,CF(P_FIELD,BL_LEVELS) ! IN Cloud fractions for boundary levs. BOUYTQ5B.80
BOUYTQ5B.81
BOUYTQ5B.82
! ARGUMENTS WITH INTENT OUT. IE: OUTPUT VARIABLES. BOUYTQ5B.83
BOUYTQ5B.84
REAL BOUYTQ5B.85
& BQ(P_FIELD,BL_LEVELS) ! OUT A buoyancy parameter (beta q tilde) BOUYTQ5B.86
&,BT(P_FIELD,BL_LEVELS) ! OUT A buoyancy parameter (beta T tilde) BOUYTQ5B.87
&,BF(P_FIELD,BL_LEVELS) ! OUT A buoyancy parameter (beta F tilde) ADM3F404.366
BOUYTQ5B.88
! LOCAL VARIABLES. BOUYTQ5B.89
BOUYTQ5B.90
REAL BOUYTQ5B.91
& QSL(P_FIELD,BL_LEVELS) ! WORK Cloud liq water (kg per kg air). BOUYTQ5B.92
BOUYTQ5B.93
INTEGER BOUYTQ5B.94
& I BOUYTQ5B.95
&, K BOUYTQ5B.96
BOUYTQ5B.97
REAL BOUYTQ5B.98
& BETAT BOUYTQ5B.99
&, BETAQ BOUYTQ5B.100
&, BETAC BOUYTQ5B.101
&, ALPHAL BOUYTQ5B.102
&, AL BOUYTQ5B.103
BOUYTQ5B.104
EXTERNAL BOUYTQ5B.105
& QSAT,QSAT_WAT,TIMER ADM3F404.367
BOUYTQ5B.107
*CALL C_0_DG_C 
BOUYTQ5B.108
*CALL C_LHEAT BOUYTQ5B.109
*CALL C_G BOUYTQ5B.110
*CALL C_R_CP BOUYTQ5B.111
*CALL C_EPSLON BOUYTQ5B.112
*CALL C_VKMAN BOUYTQ5B.113
*CALL C_SOILH BOUYTQ5B.114
*CALL C_MDI BOUYTQ5B.115
BOUYTQ5B.116
BOUYTQ5B.117
REAL ETAR,GRCP,LCRCP,LFRCP,LS,LSRCP BOUYTQ5B.118
PARAMETER ( BOUYTQ5B.119
& ETAR=1.0/(1.0-EPSILON) ! Used in buoyancy parameter BETAC. BOUYTQ5B.120
&,GRCP=G/CP ! Used in DZTL, FTL calculations. BOUYTQ5B.121
&,LCRCP=LC/CP ! Latent heat of condensation / CP. BOUYTQ5B.122
&,LFRCP=LF/CP ! Latent heat of fusion / CP. BOUYTQ5B.123
&,LS=LC+LF ! Latent heat of sublimation. BOUYTQ5B.124
&,LSRCP=LS/CP ! Latent heat of sublimation / CP. BOUYTQ5B.125
&) BOUYTQ5B.126
BOUYTQ5B.127
IF (LTIMER) THEN BOUYTQ5B.128
CALL TIMER('BOUY_TQ ',3) BOUYTQ5B.129
ENDIF BOUYTQ5B.130
!----------------------------------------------------------------------- BOUYTQ5B.131
!! 1. First loop round "boundary" levels. BOUYTQ5B.132
!----------------------------------------------------------------------- BOUYTQ5B.133
BOUYTQ5B.134
DO K=1,BL_LEVELS ARE1F404.110
BOUYTQ5B.136
!----------------------------------------------------------------------- BOUYTQ5B.137
!! 1.1 Calculate saturated specific humidity at pressure and ice/liquid BOUYTQ5B.138
!! temperature of current level (TL). BOUYTQ5B.139
!! Store pressure temporarily in BQ(*,K). BOUYTQ5B.140
!----------------------------------------------------------------------- BOUYTQ5B.141
BOUYTQ5B.142
IF (L_BL_LSPICE) THEN ADM3F404.368
CALL QSAT_WAT(QSL(P1,K),TL(P1,K),P(P1,K),P_POINTS) ADM3F404.369
ELSE ADM3F404.370
CALL QSAT(QSL(P1,K),TL(P1,K),P(P1,K),P_POINTS) ADM3F404.371
ENDIF ADM3F404.372
ENDDO ! bl_levels BOUYTQ5B.144
BOUYTQ5B.145
!----------------------------------------------------------------------- BOUYTQ5B.146
!! 1.2 Calculate buoyancy parameters BT and BQ, required for the BOUYTQ5B.147
!! calculation of Richardson numbers above the surface. BOUYTQ5B.148
!----------------------------------------------------------------------- BOUYTQ5B.149
BOUYTQ5B.150
DO K=1,BL_LEVELS ARE1F404.111
DO I=P1,P1+P_POINTS-1 BOUYTQ5B.152
BOUYTQ5B.153
BOUYTQ5B.154
BETAT = 1.0/T(I,K) ! P243.19 (1st eqn) BOUYTQ5B.155
BETAQ = C_VIRTUAL/(1.0+C_VIRTUAL*Q(I,K)-QCL(I,K)-QCF(I,K)) BOUYTQ5B.156
! ... P243.19 (2nd eqn) BOUYTQ5B.157
BOUYTQ5B.158
IF (TL(I,K).GT.TM.OR.L_BL_LSPICE) THEN ADM3F404.373
ALPHAL=(EPSILON * LC * QSL(I,K))/(R * TL(I,K) * TL(I,K) ) BOUYTQ5B.160
! ... P243.20 (Clausius-Clapeyron) for TL above freezing BOUYTQ5B.161
BOUYTQ5B.162
AL = 1.0 / (1.0 + LCRCP*ALPHAL) BOUYTQ5B.163
! ... P243.21 for TL above freezing BOUYTQ5B.164
BOUYTQ5B.165
BETAC = CF(I,K) * AL * ( LCRCP*BETAT - ETAR*BETAQ ) BOUYTQ5B.166
! ... P243.19 (3rd eqn) for TL above freezing BOUYTQ5B.167
BOUYTQ5B.168
ELSE BOUYTQ5B.169
ALPHAL = (EPSILON * LS * QSL(I,K))/(R*TL(I,K) * TL(I,K)) BOUYTQ5B.170
! ... P243.20 (Clausius-Clapeyron) for TL below freezing BOUYTQ5B.171
BOUYTQ5B.172
AL = 1.0 / (1.0 + LSRCP*ALPHAL) BOUYTQ5B.173
! ... P243.21 for TL below freezing BOUYTQ5B.174
BOUYTQ5B.175
BETAC = CF(I,K) * AL * ( LSRCP*BETAT - ETAR*BETAQ ) BOUYTQ5B.176
! ... P243.19 (3rd eqn) for TL below freezing BOUYTQ5B.177
BOUYTQ5B.178
ENDIF BOUYTQ5B.179
BT(I,K) = BETAT - ALPHAL*BETAC ! P243.18 (1st eqn) BOUYTQ5B.180
BQ(I,K) = BETAQ + BETAC ! P243.18 (2nd eqn) BOUYTQ5B.181
BF(I,K) = BETAQ*EPSILON*ETAR ADM3F404.374
ENDDO !p_points BOUYTQ5B.182
ENDDO ! bl_levels BOUYTQ5B.183
BOUYTQ5B.184
IF (LTIMER) THEN BOUYTQ5B.185
CALL TIMER('BOUY_TQ ',4) BOUYTQ5B.186
ENDIF BOUYTQ5B.187
RETURN BOUYTQ5B.188
END BOUYTQ5B.189
*ENDIF BOUYTQ5B.190