*IF DEF,A02_1A LWPTSC1A.2
C ******************************COPYRIGHT****************************** GTS2F400.5635
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.5636
C GTS2F400.5637
C Use, duplication or disclosure of this code is subject to the GTS2F400.5638
C restrictions as set forth in the contract. GTS2F400.5639
C GTS2F400.5640
C Meteorological Office GTS2F400.5641
C London Road GTS2F400.5642
C BRACKNELL GTS2F400.5643
C Berkshire UK GTS2F400.5644
C RG12 2SZ GTS2F400.5645
C GTS2F400.5646
C If no contract has been raised with this copy of the code, the use, GTS2F400.5647
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.5648
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.5649
C Modelling at the above address. GTS2F400.5650
C ******************************COPYRIGHT****************************** GTS2F400.5651
C GTS2F400.5652
CLL SUBROUTINE LWPTSC LWPTSC1A.3
CLL LWPTSC1A.4
CLL PURPOSE LWPTSC1A.5
CLL It calculates scaled pathlengths of each gaseous absorber for each LWPTSC1A.6
CLL layer and returns them in DPATH for use by LWMAST, which sums them LWPTSC1A.7
CLL to get the total scaled pathlengths between each pair of layers so LWPTSC1A.8
CLL that the gaseous transmissivities can be calculated. LWPTSC1A.9
CLL Used in version 1A (gaseous effects treated as Slingo & Wilderspin, LWPTSC1A.10
CLL 1986) of the UM LW code. LWPTSC1A.11
CLL If UPDATE *DEF CRAY is off, a version is produced which except LWPTSC1A.12
CLL for the addition of ! comments is standard FORTRAN 77 (and which LWPTSC1A.13
CLL sets the "vector length" to 1) but the standard version includes LWPTSC1A.14
CLL CRAY automatic arrays also. LWPTSC1A.15
CLL 11/1/91 - modified so that the radiative LWPTSC1A.16
CLL effectiveness of a given amount of CO2 or O3 contains a constant LWPTSC1A.17
CLL term as well as the pressure-to-the-power-alpha term. The latter, LWPTSC1A.18
CLL based on the important absorption being in pressure-broadened LWPTSC1A.19
CLL wings of strong lines, is all that is needed in the troposphere, LWPTSC1A.20
CLL but at low pressures and low pathlengths temperature-broadened LWPTSC1A.21
CLL wings and weak lines also contribute significantly. The value of LWPTSC1A.22
CLL the constants are based on single-column tests - altered on LWPTSC1A.23
CLL 14/5/91. LWPTSC1A.24
CLL LWPTSC1A.25
CLL Author: William Ingram 24 Oct 1990 LWPTSC1A.26
CLL LWPTSC1A.27
CLL Model Modification history from model version 3.0: LWPTSC1A.28
CLL version date LWPTSC1A.29
CLL 4.2 Sept.96 T3E migration: *DEF CRAY removed; GSS2F402.14
CLL *DEF T3E used for T3E library functions; GSS2F402.15
CLL dynamic allocation no longer *DEF controlled; GSS2F402.16
CLL cray HF functions replaced by T3E lib functions. GSS2F402.17
CLL S.J.Swarbrick GSS2F402.18
CLL LWPTSC1A.30
CLL It conforms to standard A of UMDP 4 (version 2, 18/1/90), and LWPTSC1A.31
CLL includes no 8X-deprecated features. , LWPTSC1A.32
CLL LWPTSC1A.33
CLL It is part of component P232 (longwave radiation) which is in task LWPTSC1A.34
CLL P23 (radiation). LWPTSC1A.35
CLL LWPTSC1A.36
CLL External documentation is in UMDP 23. LWPTSC1A.37
C*L LWPTSC1A.38
SUBROUTINE LWPTSC (H2O, CO2, O3, PSTAR, AC, BC, AB, BB, TAC, 2LWPTSC1A.39
& L2, GSS2F402.19
& NWET, NOZONE, NLEVS, L1, DPATH) LWPTSC1A.43
C* LWPTSC1A.44
*CALL LWNGASES 
LWPTSC1A.45
C*L LWPTSC1A.49
INTEGER!, INTENT (IN) :: LWPTSC1A.50
& L2, ! Number of points to be treated GSS2F402.20
& NWET, ! Number of levels with moisture - LWPTSC1A.54
C ! above these zero is used for the continuum and a small constant LWPTSC1A.55
C ! H2OLMN for line absorption (where zero would give trouble) LWPTSC1A.56
& NOZONE, ! Number of levels with ozone data LWPTSC1A.57
C ! provided - below these the value in the lowest of them is used LWPTSC1A.58
& NLEVS, ! Number of levels LWPTSC1A.59
& L1 ! First dimension of input arrays LWPTSC1A.60
C ! (The different physical assumptions about water vapour and LWPTSC1A.61
C ! ozone in levels where no data is provided means that separate LWPTSC1A.62
C ! loops are used for levels with and without water vapour but LWPTSC1A.63
C ! only the indexing needs changing for levels with and without LWPTSC1A.64
C ! their own ozone data.) LWPTSC1A.65
REAL!, INTENT(IN) :: LWPTSC1A.66
& H2O(L1,NWET), CO2, ! Mass mixing ratio (mK in UMDP 23) LWPTSC1A.67
& O3(L1,NOZONE), ! of each absorbing gas LWPTSC1A.68
& TAC(L1,NLEVS), ! Mid-layer temperatures LWPTSC1A.69
& PSTAR(L1), ! Surface pressure LWPTSC1A.70
& AC(NLEVS), BC(NLEVS), ! A & B for layer centres and LWPTSC1A.71
& AB(NLEVS+1), BB(NLEVS+1) ! boundaries LWPTSC1A.72
REAL!, INTENT(OUT) :: LWPTSC1A.73
& DPATH(L2,NGASES,NLEVS) LWPTSC1A.74
C ! The scaled pathlengths are returned in DPATH, indexed by NGASES LWPTSC1A.75
C ! 1 is CO2, 2 is H2O line absorption, 3 is O3, 4 is H2O continuum LWPTSC1A.76
CL ! LWPTSC has no EXTERNAL calls and no significant structure LWPTSC1A.77
CL ! WORK is the only dynamically allocated array GSS2F402.21
REAL WORK(L2,2,2) LWPTSC1A.81
C ! WORK is used to hold powers of layer boundary pressures used LWPTSC1A.82
C ! in 2.3.1 and passed from one level to the next to save LWPTSC1A.83
C ! re-calculation. (This does prevent autotasking over levels.) LWPTSC1A.84
REAL S9, ! Pressure scaling normalization LWPTSC1A.85
& S4, ! constants, for alpha = 0.9 & 0.4 LWPTSC1A.86
& DOPCO2, ! Constants allowing for Doppler LWPTSC1A.87
& DOPO3, ! broadening for CO2 and ozone LWPTSC1A.88
& CONCON1, ! Constants used to find the LWPTSC1A.89
& CONCON2, ! continuum pathlengths (Eq 2.3.8) LWPTSC1A.90
& CO2CON ! Constant and exponent used in LWPTSC1A.91
REAL POWER, ! temperature scaling for CO2 LWPTSC1A.92
& CO2PSC, ! Pressure-scaled CO2 pathlength LWPTSC1A.93
& DAB, ! Differences of A and B across LWPTSC1A.94
& DBB, ! current layer LWPTSC1A.95
& PTOP, ! Pressure at top of curent layer LWPTSC1A.96
& DP, ! and its pressure thickness LWPTSC1A.97
& PH ! Pressure scaling with alpha=0.9, LWPTSC1A.98
C ! used for H2O and CO2 LWPTSC1A.99
INTEGER LEVEL, J, ! Loopers over levels & points LWPTSC1A.100
& ONETWO, ! Flipper LWPTSC1A.101
& OLEVEL ! Index for the ozone data to be LWPTSC1A.102
C ! used in the current level LWPTSC1A.103
C* LWPTSC1A.104
*CALL C_G LWPTSC1A.105
*CALL C_EPSLON LWPTSC1A.106
PARAMETER ( CONCON1 = 1.66 / (G*101300.) ) LWPTSC1A.107
PARAMETER ( DOPCO2 = 1.3E-3, DOPO3 = 3.E-2 ) LWPTSC1A.108
CL Note that these constants are related to the pressure p1 at which LWPTSC1A.109
CL the "Lorentz" and "Doppler" terms are equally important: LWPTSC1A.110
CL LWPTSC1A.111
CL (p1/p0) ** ALPHA LWPTSC1A.112
CL DOPxx = ------------------ LWPTSC1A.113
CL G LWPTSC1A.114
CL LWPTSC1A.115
REAL H2OLMN ! Minimum pathlength for H2O line LWPTSC1A.116
PARAMETER ( H2OLMN = 1.E-10 ) ! absorption LWPTSC1A.117
C ! FORTRAN 77 will not allow the following constants to be LWPTSC1A.118
C ! defined in a PARAMETER statement, but the CRAY compiler will LWPTSC1A.119
C ! give the same effect as if they were. LWPTSC1A.120
S4 = 101325.**(-0.4) / (G*1.4) LWPTSC1A.121
S9 = 101325.**(-0.9) / (G*1.9) LWPTSC1A.122
CONCON2 = EXP(-1800./296.) / (0.005*EPSILON) LWPTSC1A.123
CO2CON = 2.0 / LOG(10.) LWPTSC1A.124
C LWPTSC1A.125
DO 1 J=1, L2 LWPTSC1A.126
WORK(J,1,1) = ( PSTAR(J) ) ** 1.9 LWPTSC1A.127
WORK(J,1,2) = ( PSTAR(J) ) ** 1.4 LWPTSC1A.128
C ! These lines could of course have ( PSTAR(J) * BB(1) + AB(1) ) LWPTSC1A.129
1 CONTINUE LWPTSC1A.130
ONETWO=1 LWPTSC1A.131
C LWPTSC1A.132
DO 2 LEVEL=1, NWET LWPTSC1A.133
DAB = AB(LEVEL) - AB(LEVEL+1) LWPTSC1A.134
DBB = BB(LEVEL) - BB(LEVEL+1) LWPTSC1A.135
OLEVEL = MAX (1, LEVEL+NOZONE-NLEVS) LWPTSC1A.136
DO 20 J=1, L2 LWPTSC1A.137
PTOP = PSTAR(J) * BB(LEVEL+1) + AB(LEVEL+1) LWPTSC1A.138
DP = DAB + PSTAR(J) * DBB LWPTSC1A.139
C ! First, the pressure scaling common to CO2 and H2O line: LWPTSC1A.140
WORK(J,3-ONETWO,1) = PTOP ** 1.9 LWPTSC1A.141
PH = S9 * ( WORK(J,ONETWO,1) - WORK(J,3-ONETWO,1) ) LWPTSC1A.142
C ! CO2 has temperature scaling also: (2.3.1)-(2.3.3): LWPTSC1A.143
CO2PSC = ( PH + DP * DOPCO2 ) * CO2 LWPTSC1A.144
POWER = 6.5 + CO2CON * LOG(CO2PSC) LWPTSC1A.145
IF ( POWER .LT. 0.0 ) POWER = 0.0 LWPTSC1A.146
DPATH(J,1,LEVEL) = CO2PSC * ( TAC(J,LEVEL) / 263. ) ** POWER LWPTSC1A.147
C ! For H2O line absorption just apply (2.3.1): LWPTSC1A.148
DPATH(J,2,LEVEL) = PH * H2O(J,LEVEL) LWPTSC1A.149
C ! but re-set zero humidities to a small value: LWPTSC1A.150
*IF -DEF,SCMA AJC0F405.222
IF ( DPATH(J,2,LEVEL) .EQ. 0. ) DPATH(J,2,LEVEL) = H2OLMN LWPTSC1A.151
*ELSE AJC0F405.223
IF (DPATH(J,2,LEVEL).LE.0.0) DPATH(J,2,LEVEL) = H2OLMN AJC0F405.224
*ENDIF AJC0F405.225
C ! For ozone (2.3.1) only: LWPTSC1A.152
WORK(J,3-ONETWO,2) = PTOP ** 1.4 LWPTSC1A.153
DPATH(J,3,LEVEL) = O3(J,OLEVEL) * LWPTSC1A.154
& ( S4 * ( WORK(J,ONETWO,2) - WORK(J,3-ONETWO,2) ) + DP * DOPO3 ) LWPTSC1A.155
C ! For the H2O continuum apply (2.3.8): LWPTSC1A.156
DPATH(J,4,LEVEL) = CONCON1 * H2O(J,LEVEL) * LWPTSC1A.157
& ( PSTAR(J) * BC(LEVEL) + AC(LEVEL) ) * ( PSTAR(J) * DBB + DAB ) LWPTSC1A.158
& * ( 1. + CONCON2 * H2O(J,LEVEL) * EXP ( 1800. / TAC(J,LEVEL) ) ) LWPTSC1A.159
20 CONTINUE LWPTSC1A.160
ONETWO = 3 - ONETWO ! Flip ONETWO so that the numbers LWPTSC1A.161
C ! we are avoiding recalculating do not have to be copied either LWPTSC1A.162
2 CONTINUE LWPTSC1A.163
C LWPTSC1A.164
C ! Above the levels where moisture is calculated, put in constant LWPTSC1A.165
C ! for the H2O pathlength but treat CO2 and O3 the same: LWPTSC1A.166
C LWPTSC1A.167
DO 3 LEVEL=NWET+1, NLEVS LWPTSC1A.168
DAB = AB(LEVEL) - AB(LEVEL+1) LWPTSC1A.169
DBB = BB(LEVEL) - BB(LEVEL+1) LWPTSC1A.170
OLEVEL = MAX (1, LEVEL+NOZONE-NLEVS) LWPTSC1A.171
DO 30 J=1, L2 LWPTSC1A.172
PTOP = PSTAR(J) * BB(LEVEL+1) + AB(LEVEL+1) LWPTSC1A.173
DP = DAB + PSTAR(J) * DBB LWPTSC1A.174
C ! CO2 is scaled just as before: LWPTSC1A.175
WORK(J,3-ONETWO,1) = PTOP ** 1.9 LWPTSC1A.176
PH = S9 * ( WORK(J,ONETWO,1) - WORK(J,3-ONETWO,1) ) LWPTSC1A.177
CO2PSC = ( PH + DP * DOPCO2 ) * CO2 LWPTSC1A.178
POWER = 6.5 + CO2CON * LOG(CO2PSC) LWPTSC1A.179
IF ( POWER .LT. 0.0 ) POWER = 0.0 LWPTSC1A.180
DPATH(J,1,LEVEL) = CO2PSC * ( TAC(J,LEVEL) / 263. ) ** POWER LWPTSC1A.181
WORK(J,3-ONETWO,2) = PTOP ** 1.4 LWPTSC1A.182
C ! and so is O3: LWPTSC1A.183
DPATH(J,3,LEVEL) = O3(J,OLEVEL) * LWPTSC1A.184
& ( S4 * ( WORK(J,ONETWO,2) - WORK(J,3-ONETWO,2) ) + DP * DOPO3 ) LWPTSC1A.185
C ! For H2O line absorption just put in a small constant: LWPTSC1A.186
DPATH(J,2,LEVEL) = H2OLMN LWPTSC1A.187
C ! For the H2O continuum can use zero since this goes into EXP LWPTSC1A.188
C ! rather than LOG: LWPTSC1A.189
DPATH(J,4,LEVEL) = 0. LWPTSC1A.190
30 CONTINUE LWPTSC1A.191
ONETWO = 3 - ONETWO ! Flip ONETWO as before LWPTSC1A.192
3 CONTINUE LWPTSC1A.193
C LWPTSC1A.194
RETURN LWPTSC1A.195
END LWPTSC1A.196
*ENDIF LWPTSC1A.197