*IF DEF,A02_1A LWTRAN1A.2
C ******************************COPYRIGHT****************************** GTS2F400.5725
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.5726
C GTS2F400.5727
C Use, duplication or disclosure of this code is subject to the GTS2F400.5728
C restrictions as set forth in the contract. GTS2F400.5729
C GTS2F400.5730
C Meteorological Office GTS2F400.5731
C London Road GTS2F400.5732
C BRACKNELL GTS2F400.5733
C Berkshire UK GTS2F400.5734
C RG12 2SZ GTS2F400.5735
C GTS2F400.5736
C If no contract has been raised with this copy of the code, the use, GTS2F400.5737
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.5738
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.5739
C Modelling at the above address. GTS2F400.5740
C ******************************COPYRIGHT****************************** GTS2F400.5741
C GTS2F400.5742
CLL Subroutine LWTRAN ---------------------------------------------- LWTRAN1A.3
CLL LWTRAN1A.4
CLL Purpose : LWTRAN1A.5
CLL It calculates clear-sky transmissivities in each of the NBANDS LWTRAN1A.6
CLL longwave spectral bands (and, optionally, additional diagnostic LWTRAN1A.7
CLL ones) from the pathlengths for each effective absorbing gas. LWTRAN1A.8
CLL (Where the absorption by a gas includes terms with different LWTRAN1A.9
CLL pathlength scaling, like water vapour line & continuum, they are LWTRAN1A.10
CLL different gases as far as LWTRAN is concerned.) It uses look-up LWTRAN1A.11
CLL tables derived from line data as described by Slingo and Wilderspin LWTRAN1A.12
CLL (April 1986, Quart.J.R.Met.Soc., 112, 472, 371-386), or UMDP 23, LWTRAN1A.13
CLL which incorporate a full angular integration. Interpolation is LWTRAN1A.14
CLL logarithmic in the pathlength, with values at half-decade intervals LWTRAN1A.15
CLL from 10**-9 to 10**3 kg/m2. LWTRAN1A.16
CLL The version of routines LWTRAN and LWLKIN LWTRAN1A.17
CLL used in version 1A (gaseous effects treated as in Slingo & LWTRAN1A.18
CLL Wilderspin, 1986) of the UM LW code. LWTRAN1A.19
CLL LWLKIN must be CALLed to initialize TRTAB before LWTRAN is CALLed LWTRAN1A.20
CLL (LWTRAN would normally be CALLed via LWMAST and LWRAD). LWTRAN1A.21
CLL LWTRAN1A.22
CLL Author: William Ingram LWTRAN1A.23
CLL LWTRAN1A.24
CLL Model Modification history from model version 3.0: LWTRAN1A.25
CLL version Date LWTRAN1A.26
CLL 4.2 Sept.96 T3E migration: *DEF CRAY removed; GSS3F402.115
CLL *DEF T3E used for T3E library functions; GSS3F402.116
CLL dynamic allocation no longer *DEF controlled; GSS3F402.117
CLL cray HF functions replaced by T3E lib functions. GSS3F402.118
CLL S.J.Swarbrick GSS3F402.119
CLL LWTRAN1A.27
CLL Programming standard : LWTRAN1A.28
CLL It conforms with standard A of version 3 (07/9/90) of UMDP 4, and LWTRAN1A.29
CLL contains no 8X-deprecated features. LWTRAN1A.30
CLL If UPDATE *DEF CRAY is off, the code is standard FORTRAN 77 except LWTRAN1A.31
CLL for having ! comments (it then sets the "vector length" to 1) but LWTRAN1A.32
CLL otherwise it includes an automatic array also. LWTRAN1A.33
CLL LWTRAN1A.34
CLL Logical components covered : P23 LWTRAN1A.35
CLL Component 232 (longwave radiation), LWTRAN1A.36
CLL It is also intended to be easily extended to perform LWTRAN1A.37
CLL some of the functions of D23 (radiation diagnostics), by diagnosing LWTRAN1A.38
CLL additional transmissivities. LWTRAN1A.39
CLL LWTRAN1A.40
CLL Project task : P23 (radiation) LWTRAN1A.41
CLL LWTRAN1A.42
CLL External documentation: UMDP 23. LWTRAN1A.43
CLL LWTRAN1A.44
CLLEND ----------------------------------------------------------------- LWTRAN1A.45
C*L LWTRAN1A.46
SUBROUTINE LWTRAN (PATH, TRTAB, DTRTAB, FLSTBD, KEXP, 6LWTRAN1A.47
& L, GSS3F402.120
& TRANS) LWTRAN1A.51
C* LWTRAN1A.52
*CALL LWNBANDS 
LWTRAN1A.53
*CALL LWNGASES LWTRAN1A.54
*CALL LWNTRANS LWTRAN1A.55
*CALL LWNLKUPS LWTRAN1A.56
*CALL LWTABLE LWTRAN1A.57
C*L LWTRAN1A.63
INTEGER!, INTENT(IN) :: LWTRAN1A.64
& L, ! Number of points GSS3F402.121
& FLSTBD(NGASES,2) ! First & last band in which each LWTRAN1A.68
C ! effective gas is active LWTRAN1A.69
REAL!, INTENT(IN) :: LWTRAN1A.70
& PATH (L,NGASES), ! Scaled pathlengths for each gas LWTRAN1A.71
& TRTAB(IT,NTRANS,NGASES), ! Transmissivity look-up table LWTRAN1A.72
& DTRTAB(IT,NTRANS,NGASES), ! and table of its differences LWTRAN1A.73
& KEXP(NTRANS) ! k1 in Eq 2.3.6, used instead of LWTRAN1A.74
C ! (D)TRTAB for continuum absorption. LWTRAN1A.75
REAL!, INTENT(OUT) :: LWTRAN1A.76
& TRANS(L,NTRANS) ! Transmissivities LWTRAN1A.77
C* LWTRAN1A.78
CL ! No EXTERNAL routines called LWTRAN1A.79
CL ! Two workspace arrays of size L, one real (Y) & one integer (I) GSS3F402.122
C LWTRAN1A.85
REAL RLNR10, ! NDEC/ln(10) LWTRAN1A.86
& TGAS, ! Transmissivity due to a single "gas" LWTRAN1A.87
& Y(L) ! Used in the interpolation LWTRAN1A.88
INTEGER JTRANS, GAS, J, ! Loop over transmissivity, gas & point LWTRAN1A.89
& I(L) ! INT(Y) LWTRAN1A.90
! GSS3F402.123
! Local workspace GSS3F402.124
REAL LOGPATH(L,3) GSS1F403.2
REAL EXPPATH(FLSTBD(4,2)-FLSTBD(4,1)+1,L) GSS1F403.3
INTEGER fldiff GSS3F402.127
! GSS3F402.128
! No. of rows for exp_v32 function GSS3F402.129
fldiff = FLSTBD(4,2) - FLSTBD(4,1) + 1 GSS3F402.130
! GSS3F402.131
RLNR10 = REAL(NDEC) / LOG(10.) ! Cannot put this in a LWTRAN1A.91
C ! PARAMETER statement in FORTRAN77, but the CRAY compiler's LWTRAN1A.92
C ! optimizer will make it have the same effect as if it were. LWTRAN1A.93
C LWTRAN1A.94
C ! First, initialize the transmissivities to 1 - we will assume LWTRAN1A.95
C ! random overlap of lines of different gases, so that the total LWTRAN1A.96
C ! transmissivity in each band is the product of the LWTRAN1A.97
C ! transmissivities for the individual gases. LWTRAN1A.98
C LWTRAN1A.99
DO 1 JTRANS=1, NTRANS LWTRAN1A.100
Cfpp$ Select(CONCUR) LWTRAN1A.101
DO 1 J=1, L LWTRAN1A.102
TRANS(J,JTRANS) = 1. LWTRAN1A.103
1 CONTINUE LWTRAN1A.104
C LWTRAN1A.105
C ! Then loop through those effective gases which use look-up tables LWTRAN1A.106
C LWTRAN1A.107
*IF DEF,VECTLIB PXVECTLB.99
! Use fast t3e vector function GSS3F402.133
DO J=1,L GSS3F402.134
DO GAS=1,3 GSS3F402.135
logpath(j,gas)=path(j,gas) GSS3F402.136
END DO GSS3F402.137
END DO GSS3F402.138
call alog_v(l*3, logpath, logpath) GSS1F403.4
*ELSE GSS3F402.140
DO J=1,L GSS3F402.141
DO GAS=1,3 GSS3F402.142
logpath(j,gas)=log(path(j,gas)) GSS3F402.143
END DO GSS3F402.144
END DO GSS3F402.145
*ENDIF GSS3F402.146
! GSS3F402.147
DO 2 GAS=1, 3 LWTRAN1A.108
Cfpp$ Select(CONCUR) LWTRAN1A.109
DO 20 J=1, L LWTRAN1A.110
Y(J) = LOGPATH(J,GAS) * RLNR10 + OFFSET GSS3F402.148
C GSS3F402.149
C OFFSET ALLLOWS FOR THE START-POINT OF THE TABLES (SAME FOR ALL GASES). LWTRAN1A.116
I(J) = INT(Y(J)) LWTRAN1A.120
Y(J) = Y(J) - REAL(I(J)) LWTRAN1A.121
IF (I(J).GT.IT) I(J) = IT LWTRAN1A.122
20 CONTINUE LWTRAN1A.123
DO 22 JTRANS=FLSTBD(GAS,1), FLSTBD(GAS,2) LWTRAN1A.124
Cfpp$ Select(CONCUR) LWTRAN1A.125
DO 22 J=1, L LWTRAN1A.126
IF (I(J).GE.1) THEN LWTRAN1A.127
TGAS = TRTAB(I(J),JTRANS,GAS) + Y(J)*DTRTAB(I(J),JTRANS,GAS) LWTRAN1A.128
ELSE LWTRAN1A.129
TGAS = LWTRAN1A.130
& 1. - ( 1. - TRTAB(1,JTRANS,GAS) ) * PATH(J,GAS) / ZSTART LWTRAN1A.131
ENDIF LWTRAN1A.134
C ! Assume random overlap of lines of different gases, so that LWTRAN1A.135
C ! the total transmissivity is the product of the LWTRAN1A.136
C ! transmissivities for the individual gases: LWTRAN1A.137
TRANS(J,JTRANS) = TRANS(J,JTRANS) * TGAS LWTRAN1A.138
22 CONTINUE LWTRAN1A.139
2 CONTINUE LWTRAN1A.140
C LWTRAN1A.141
C ! Currently H2O continuum is just exponential (2.3.4), & CFCs will LWTRAN1A.142
C ! be too. Again, transmissivities just multiply: LWTRAN1A.143
C LWTRAN1A.144
! Use exppath to store products.... GSS3F402.150
do jtrans = FLSTBD(4,1), FLSTBD(4,2) GSS3F402.151
do j = 1,L GSS3F402.152
exppath(jtrans-FLSTBD(4,1)+1,j) = KEXP(JTRANS)*PATH(J,4) GSS3F402.153
end do GSS3F402.154
end do GSS3F402.155
GSS3F402.156
! ....then compute exp of products in exppath GSS3F402.157
*IF DEF,VECTLIB PXVECTLB.100
! Use fast t3e vector function GSS3F402.159
call exp_v(fldiff*l,exppath,exppath) GSS1F403.5
*ELSE GSS3F402.161
DO JTRANS=1,FLSTBD(4,2)-FLSTBD(4,1)+1 GSS3F402.162
DO J=1,L GSS3F402.163
exppath(jtrans,j)=exp(exppath(jtrans,j)) GSS3F402.164
end do GSS3F402.165
end do GSS3F402.166
*ENDIF GSS3F402.167
GSS3F402.168
DO 3 JTRANS=FLSTBD(4,1), FLSTBD(4,2) LWTRAN1A.145
Cfpp$ Select(CONCUR) LWTRAN1A.146
DO 30 J=1, L LWTRAN1A.147
TRANS(J,JTRANS) = LWTRAN1A.148
& TRANS(J,JTRANS) * EXPPATH(JTRANS-FLSTBD(4,1)+1,J) GSS3F402.169
30 CONTINUE LWTRAN1A.154
3 CONTINUE LWTRAN1A.155
C LWTRAN1A.156
RETURN LWTRAN1A.157
END LWTRAN1A.158
SUBROUTINE LWLKIN (LWLUT) 2LWTRAN1A.159
*CALL LWNBANDS LWTRAN1A.160
*CALL LWNGASES LWTRAN1A.161
*CALL LWNTRANS LWTRAN1A.162
*CALL LWNLKUPS LWTRAN1A.163
REAL!, INTENT(OUT) LWTRAN1A.164
& LWLUT(IT,NTRANS,NGASES,2) LWTRAN1A.165
REAL TRTAB(IT,NTRANS,NGASES), LWTRAN1A.166
& CO2(IT), WL(IT,6), WC(IT,4), O3(IT) LWTRAN1A.167
C ! Equivalence arrays named after the various gases to the relevant LWTRAN1A.168
C ! areas of TRTAB, to make the DATA statements easier to understand LWTRAN1A.169
C ! and to change the order in which the gases are treated. LWTRAN1A.170
EQUIVALENCE LWTRAN1A.171
& (CO2(1),TRTAB(1,3,1)), (WL(1,1),TRTAB(1,1,2)), LWTRAN1A.172
& (O3(1),TRTAB(1,4,3)), (WC(1,1),TRTAB(1,2,4)) LWTRAN1A.173
INTEGER JTRANS, GAS, J ! Loop over transmissivity, gas & point LWTRAN1A.174
*CALL LWLKUPNU LWTRAN1A.175
C ! Initialize unused parts to zero to prevent INDEF problems LWTRAN1A.176
DATA ((TRTAB(J,JTRANS,1),J=1,IT),JTRANS=1,2), LWTRAN1A.177
& ((TRTAB(J,JTRANS,1),J=1,IT),JTRANS=4,6), LWTRAN1A.178
& ((TRTAB(J,JTRANS,3),J=1,IT),JTRANS=1,3), LWTRAN1A.179
& ((TRTAB(J,JTRANS,3),J=1,IT),JTRANS=5,6), LWTRAN1A.180
& ((TRTAB(J,JTRANS,4),J=1,IT),JTRANS=1,6) LWTRAN1A.181
& / IT*0., IT*0., IT*0., IT*0., IT*0., IT*0., IT*0., IT*0., LWTRAN1A.182
& IT*0., IT*0., IT*0., IT*0., IT*0., IT*0., IT*0., IT*0. / LWTRAN1A.183
C LWTRAN1A.184
DO 1 GAS=1, NGASES LWTRAN1A.185
DO 1 JTRANS=1, NTRANS LWTRAN1A.186
DO 1 J=1, IT LWTRAN1A.187
LWLUT(J,JTRANS,GAS,1) = TRTAB(J,JTRANS,GAS) LWTRAN1A.188
1 CONTINUE LWTRAN1A.189
C LWTRAN1A.190
DO 2 GAS=1, NGASES LWTRAN1A.191
DO 2 JTRANS=1, NTRANS LWTRAN1A.192
DO 2 J=1, IT-1 LWTRAN1A.193
LWLUT(J,JTRANS,GAS,2) = LWTRAN1A.194
& LWLUT(J+1,JTRANS,GAS,1) - LWLUT(J,JTRANS,GAS,1) LWTRAN1A.195
2 CONTINUE LWTRAN1A.196
C LWTRAN1A.197
C ! Set the last element for each gas and band to zero, so that the LWTRAN1A.198
C ! extrapolation done for any pathlength greater than the maximum LWTRAN1A.199
C ! catered for just gives the greatest value in TRTAB. LWTRAN1A.200
C LWTRAN1A.201
DO 3 GAS=1, NGASES LWTRAN1A.202
DO 3 JTRANS=1, NTRANS LWTRAN1A.203
LWLUT(IT,JTRANS,GAS,2) = 0. LWTRAN1A.204
3 CONTINUE LWTRAN1A.205
C LWTRAN1A.206
RETURN LWTRAN1A.207
END LWTRAN1A.208
*ENDIF LWTRAN1A.209