*IF DEF,A02_1B LWTRAN1B.2
C ******************************COPYRIGHT****************************** GTS2F400.5743
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.5744
C GTS2F400.5745
C Use, duplication or disclosure of this code is subject to the GTS2F400.5746
C restrictions as set forth in the contract. GTS2F400.5747
C GTS2F400.5748
C Meteorological Office GTS2F400.5749
C London Road GTS2F400.5750
C BRACKNELL GTS2F400.5751
C Berkshire UK GTS2F400.5752
C RG12 2SZ GTS2F400.5753
C GTS2F400.5754
C If no contract has been raised with this copy of the code, the use, GTS2F400.5755
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.5756
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.5757
C Modelling at the above address. GTS2F400.5758
C ******************************COPYRIGHT****************************** GTS2F400.5759
C GTS2F400.5760
CLL Subroutine LWTRAN ---------------------------------------------- LWTRAN1B.3
CLL LWTRAN1B.4
CLL Purpose : LWTRAN1B.5
CLL It calculates clear-sky transmissivities in each of the NBANDS LWTRAN1B.6
CLL longwave spectral bands (and, optionally, additional diagnostic LWTRAN1B.7
CLL ones) from the pathlengths for each effective absorbing gas in LWTRAN1B.8
CLL each band. (Where the absorption by a gas includes terms with LWTRAN1B.9
CLL different pathlength scaling, like water vapour line & continuum, LWTRAN1B.10
CLL they are treated as two gases.) LWTRAN1B.11
CLL The version of routine LWTRAN used in LWTRAN1B.12
CLL version 1B (gaseous effects treated as Morcrette et al, 1986) of LWTRAN1B.13
CLL the UM LW code, and a dummy version of routine LWLKIN for LWTRAN1B.14
CLL compatibility with other versions. LWTRAN1B.15
CLL Version 3, part of the alternative code giving "ECMWF-like" LWTRAN1B.16
CLL treatment of LW gaseous transmissivities, following Morcrette et al LWTRAN1B.17
CLL (J.-J. Morcrette, L.D. Smith & Y. Fouquart, 1986, Beitr. Phys. LWTRAN1B.18
CLL Atmosph., 59, 455-469). All the calculations are changed: instead LWTRAN1B.19
CLL of look-up tables for line absorption, ozone uses a Malkmus model, LWTRAN1B.20
CLL and CO2 and water vapour use Horner's algorithm, while the LWTRAN1B.21
CLL continuum terms, though still exponential, are calculated rather LWTRAN1B.22
CLL indirectly to save evaluation of exponentials. Also, different LWTRAN1B.23
CLL pathlengths are generally used for different bands, and the LWTRAN1B.24
CLL pathlengths are assumed to contain a diffusivity factor. Version 3 LWTRAN1B.25
CLL of LWTRAN was set up from version 2.1 to be part of version 1B LWTRAN1B.26
CLL (ECMWF-like gaseous transmissivities) of the LW from release 2.7 of LWTRAN1B.27
CLL the UM. William Ingram 22 June 1992 LWTRAN1B.28
CLL LWTRAN1B.29
CLL Author: William Ingram LWTRAN1B.30
CLL LWTRAN1B.31
CLL Model Modification history from model version 3.0: LWTRAN1B.32
CLL version Date LWTRAN1B.33
CLL 4.2 Sept.96 T3E migration: routine optimised using cray vector GSS1F403.960
CLL library functions & appropriately restructured. GSS1F403.961
CLL D.Salmond & S.J.Swarbrick GSS1F403.962
CLL LWTRAN1B.34
CLL Programming standard : LWTRAN1B.35
CLL It conforms with standard A of version 3 (07/9/90) of UMDP 4, and LWTRAN1B.36
CLL contains no 8X-deprecated features. LWTRAN1B.37
CLL If UPDATE *DEF CRAY is off, the code is standard FORTRAN 77 except LWTRAN1B.38
CLL for having ! comments (it then sets the "vector length" to 1) but LWTRAN1B.39
CLL otherwise it includes an automatic array also. LWTRAN1B.40
CLL LWTRAN1B.41
CLL Logical components covered : P232 LWTRAN1B.42
CLL P232 (longwave radiation), LWTRAN1B.43
CLL It is also intended to be easily extended to perform LWTRAN1B.44
CLL some of the functions of D23 (radiation diagnostics), by diagnosing LWTRAN1B.45
CLL additional transmissivities. LWTRAN1B.46
CLL LWTRAN1B.47
CLL Project task : P23 (radiation) LWTRAN1B.48
CLL LWTRAN1B.49
CLL External documentation: UMDP 23. LWTRAN1B.50
CLL LWTRAN1B.51
CLLEND ----------------------------------------------------------------- LWTRAN1B.52
C*L LWTRAN1B.53
SUBROUTINE LWTRAN (PATH, DUMMY1, DUMMY2, DUMMY3, DUMMY4, 6LWTRAN1B.54
& L, GSS3F402.175
& TRANS) LWTRAN1B.58
C* LWTRAN1B.59
*CALL LWNBANDS 
LWTRAN1B.60
*CALL LWNGASES LWTRAN1B.61
*CALL LWNTRANS LWTRAN1B.62
C*L LWTRAN1B.70
INTEGER!, INTENT(IN) :: LWTRAN1B.71
& L, ! Number of points GSS3F402.176
& DUMMY3 ! Not used in this version, but left LWTRAN1B.75
C ! as an argument for compatibility LWTRAN1B.76
REAL!, INTENT(IN) :: LWTRAN1B.77
& PATH (L,NGASES), ! Scaled pathlengths for each gas LWTRAN1B.78
& DUMMY1, DUMMY2, ! Not used in this version, but left LWTRAN1B.79
& DUMMY4 ! as arguments for compatibility LWTRAN1B.80
REAL!, INTENT(OUT) :: LWTRAN1B.81
& TRANS(L,NTRANS) ! Transmissivities LWTRAN1B.82
C* LWTRAN1B.83
CL ! No EXTERNAL routines called LWTRAN1B.84
*CALL LWGAFD LWTRAN1B.88
C LWTRAN1B.89
REAL SRAP, ! SQRT ( scaled pathlength ) LWTRAN1B.90
& TCO22, ! CO2 transmissivities for LWTRAN1B.91
& TCO234, ! band 2, & for both 3 & 4. LWTRAN1B.92
& FBWCP1, ! Foreign- and Self- LWTRAN1B.93
& SBWCP1, ! Broadened Water vapour LWTRAN1B.94
& FBWCP2, FBWCP4, FBWCP8, ! Continuum terms, being two LWTRAN1B.95
& FBWC16, FBWC32, FBWCPQ, FBWCPH, ! particular exponentials to GSS3F402.177
& SBWCP2, SBWCP4, SBWCP8, ! the Powers 1, 2, 4, 8, 16, LWTRAN1B.97
& SBWC16, SBWC32, SBWCPQ, SBWCPH, ! 32, a Half & a Quarter. GSS3F402.178
& FBWCB2, FBWCB3, ! Foreign- and Self- LWTRAN1B.99
& FBWCB4, FBWCB5, ! Broadened Water vapour LWTRAN1B.100
& SBWCB2, SBWCB3, ! Continuum transmissivities, LWTRAN1B.101
& SBWCB4, SBWCB5, ! in Bands 2-5 LWTRAN1B.102
& TO31, ! Ozone transmissivities in LWTRAN1B.103
& TO32, ! 2 fractions of the band. LWTRAN1B.104
& UXY(2*L), ! Used for the Malkmus GSS1F403.963
& VXY(2*L) ! calculation of TO31,2 - GSS1F403.964
! VXY is the ozone-pathlength-weighted mean pressure over the GSS3F402.179
! pathlength, & UXY is twice the unscaled path divided by VXY. GSS3F402.180
INTEGER J, BAND,K ! Loopers over point & band GSS1F403.965
C LWTRAN1B.110
! Local workspace used for t3e optimisation GSS3F402.181
REAL sqrt_uxy(2*L) GSS1F403.966
REAL exp_vxy(2*L) GSS1F403.967
REAL utemp,vtemp GSS1F403.968
REAL EXPPATH(L,4) GSS1F403.969
*IF DEF,VECTLIB PXVECTLB.101
REAL sqrt_PATH (L,8) PXVECTLB.102
call sqrt_v(L*8,path,sqrt_path) PXVECTLB.103
*ENDIF PXVECTLB.104
C LWTRAN1B.111
DO JTRANS=1, NTRANS GSS3F402.183
DO J=1, L GSS3F402.184
CL ! Horner's algorithm for H2O transmission LWTRAN1B.115
*IF DEF,VECTLIB PXVECTLB.105
SRAP = sqrt_path(J,JTRANS) GSS1F403.978
*ELSE GSS1F403.979
SRAP = sqrt(PATH(j,jtrans)) GSS1F403.980
*ENDIF GSS1F403.981
TRANS(J,JTRANS) = ( PADE(1,JTRANS) + SRAP * PADE(2,JTRANS) ) LWTRAN1B.117
& /( PADE(1,JTRANS)+SRAP*(PADE(3,JTRANS)+SRAP) ) GSS3F402.186
END DO GSS3F402.187
END DO GSS3F402.188
C LWTRAN1B.121
DO J=1,L GSS3F402.191
EXPPATH(J,1)=-0.002*PATH(J, 9) GSS3F402.192
EXPPATH(J,2)=0.25*EXPPATH(J,1) GSS1F403.982
EXPPATH(J,3)= -PATH(J,10) GSS1F403.983
EXPPATH(J,4)=0.25*EXPPATH(J,3) GSS1F403.984
END DO GSS3F402.194
*IF DEF,VECTLIB PXVECTLB.106
! Use t3e fast vector functions GSS1F403.986
call exp_v(L*4,EXPPATH,EXPPATH) GSS1F403.987
*ELSE GSS3F402.196
DO K=1,4 GSS1F403.988
DO J=1,L GSS1F403.989
EXPPATH(J,K)=EXP(EXPPATH(J,K)) GSS1F403.990
END DO GSS1F403.991
END DO GSS1F403.992
*ENDIF GSS3F402.202
DO J = 1, L LWTRAN1B.123
utemp = 4. * PATH(J,11) * PATH(J,11) GSS1F403.993
& /( PIALF * PATH(J,12) ) GSS1F403.994
uxy(j)=1.+O3M1*utemp GSS1F403.995
uxy(j+l)=1.+O3M2*utemp GSS1F403.996
ENDDO GSS1F403.997
*IF DEF,VECTLIB PXVECTLB.107
call sqrt_v(2*l,uxy,sqrt_uxy) GSS1F403.999
*ELSE GSS1F403.1000
DO J=1,2*L GSS1F403.1001
sqrt_uxy(j)=sqrt(uxy(j)) GSS1F403.1002
ENDDO GSS1F403.1003
*ENDIF GSS1F403.1004
DO J = 1, L GSS1F403.1005
vtemp = PIALF * PATH(J,12) GSS1F403.1006
& /( 2. * PATH(J,11) ) GSS1F403.1007
vxy(j)=-(sqrt_uxy(j)-1.)*vtemp GSS1F403.1008
vxy(j+l)=-(sqrt_uxy(j+l)-1.)*vtemp GSS1F403.1009
ENDDO GSS1F403.1010
*IF DEF,VECTLIB PXVECTLB.108
call exp_v(2*l,vxy,exp_vxy) GSS1F403.1012
*ELSE GSS1F403.1013
DO J=1,2*L GSS1F403.1014
exp_vxy(j)=exp(vxy(j)) GSS1F403.1015
ENDDO GSS1F403.1016
*ENDIF GSS1F403.1017
DO J = 1, L GSS1F403.1018
CL ! Horner's algorithm for CO2 transmission LWTRAN1B.124
*IF DEF,VECTLIB PXVECTLB.109
SRAP= sqrt_path(j,7) GSS1F403.1020
*ELSE GSS1F403.1021
SRAP = sqrt(PATH(j,7)) GSS3F402.203
*ENDIF GSS1F403.1022
TCO22 = ( PADE(1,7) + SRAP*PADE(2,7) ) / GSS3F402.204
& ( PADE(1,7)+ SRAP * ( PADE(3,7) + SRAP ) ) GSS3F402.205
C LWTRAN1B.129
*IF DEF,VECTLIB PXVECTLB.110
SRAP= sqrt_path(j,8) GSS1F403.1024
*ELSE GSS1F403.1025
SRAP = sqrt(PATH(j,8)) GSS3F402.206
*ENDIF GSS1F403.1026
GSS1F403.1027
TCO234 = ( PADE(1,8) + SRAP*PADE(2,8) ) / GSS3F402.207
& ( PADE(1,8) + SRAP * ( PADE(3,8) + SRAP ) ) LWTRAN1B.132
C LWTRAN1B.135
FBWCP1 = EXPPATH(J,1) GSS3F402.208
GSS3F402.209
FBWCP2 = FBWCP1 * FBWCP1 LWTRAN1B.141
FBWCP4 = FBWCP2 * FBWCP2 LWTRAN1B.142
FBWCP8 = FBWCP4 * FBWCP4 LWTRAN1B.143
FBWC16 = FBWCP8 * FBWCP8 LWTRAN1B.144
FBWC32 = FBWC16 * FBWC16 LWTRAN1B.145
GSS1F403.1028
FBWCPQ = EXPPATH(J,2) GSS1F403.1029
C LWTRAN1B.148
FBWCB5 = FBWC32 * FBWC32 * FBWC16 GSS1F403.1030
FBWCB2 = FBWC32 * FBWCB5 GSS1F403.1031
FBWCB3 = FBWCP4 * FBWCP2 * FBWCPQ LWTRAN1B.150
FBWCB4 = FBWCP4 * FBWCP1 LWTRAN1B.151
C LWTRAN1B.153
SBWCP1 = EXPPATH(J,3) GSS1F403.1032
C GSS3F402.211
SBWCP2 = SBWCP1 * SBWCP1 LWTRAN1B.159
SBWCP4 = SBWCP2 * SBWCP2 LWTRAN1B.160
SBWCP8 = SBWCP4 * SBWCP4 LWTRAN1B.161
SBWC16 = SBWCP8 * SBWCP8 LWTRAN1B.162
SBWC32 = SBWC16 * SBWC16 LWTRAN1B.163
GSS1F403.1033
SBWCPQ = EXPPATH(J,4) GSS1F403.1034
C LWTRAN1B.166
SBWCB2 = SBWCP8 * SBWCP4 LWTRAN1B.167
SBWCB3 = SBWCP4 * SBWCP2 * SBWCPQ LWTRAN1B.168
SBWCB4 = SBWCP4 * SBWCP1 LWTRAN1B.169
SBWCB5 = SBWC32 * SBWC32 * SBWC16 LWTRAN1B.170
C LWTRAN1B.171
TRANS(J,2) = TRANS(J,2) * FBWCB2 * SBWCB2 * TCO22 GSS1F403.1035
TRANS(J,3) = TRANS(J,3) * FBWCB3 * SBWCB3 * TCO234 GSS1F403.1036
TRANS(J,4) = TRANS(J,4) * FBWCB4 * SBWCB4 * TCO234 GSS1F403.1037
1 * ( O3WT1 * exp_vxy(j) + O3WT2 * exp_vxy(j+l)) GSS1F403.1038
TRANS(J,5) = TRANS(J,5) * FBWCB5 * SBWCB5 LWTRAN1B.175
C LWTRAN1B.176
ENDDO LWTRAN1B.187
C LWTRAN1B.188
RETURN LWTRAN1B.189
END LWTRAN1B.190
SUBROUTINE LWLKIN (DUMMY) 2LWTRAN1B.191
CLL ! Dummy routine provided in version 1B of the LW from release 2.7 LWTRAN1B.192
CLL ! of the UM for compatibility with version 1A and the LWTRAN1B.193
CLL ! control-level routines. LWTRAN1B.194
REAL DUMMY ! A dummy argument in all senses. LWTRAN1B.195
RETURN LWTRAN1B.196
END LWTRAN1B.197
*ENDIF A02_1B LWTRAN1B.198