*IF DEF,A02_1C LWTRAN1C.2
C ******************************COPYRIGHT****************************** GTS2F400.5761
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.5762
C GTS2F400.5763
C Use, duplication or disclosure of this code is subject to the GTS2F400.5764
C restrictions as set forth in the contract. GTS2F400.5765
C GTS2F400.5766
C Meteorological Office GTS2F400.5767
C London Road GTS2F400.5768
C BRACKNELL GTS2F400.5769
C Berkshire UK GTS2F400.5770
C RG12 2SZ GTS2F400.5771
C GTS2F400.5772
C If no contract has been raised with this copy of the code, the use, GTS2F400.5773
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.5774
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.5775
C Modelling at the above address. GTS2F400.5776
C ******************************COPYRIGHT****************************** GTS2F400.5777
C GTS2F400.5778
CLL *DECK LWTRAN, CONTAINING ROUTINES LWTRAN AND LWLKIN. LWTRAN1C.3
CLL LWLKIN MUST BE CALLED TO INITIALIZE TRTAB BEFORE LWTRAN IS CALLED LWTRAN1C.4
CLL (LWTRAN WOULD NORMALLY BE CALLED VIA LWMAST AND LWRAD). LWTRAN1C.5
CLL IF UPDATE *DEF CRAY IS OFF, THE CODE IS STANDARD FORTRAN 77 EXCEPT LWTRAN1C.6
CLL FOR HAVING ! COMMENTS (IT THEN SETS THE "VECTOR LENGTH" TO 1) BUT LWTRAN1C.7
CLL OTHERWISE IT INCLUDES AN AUTOMATIC ARRAY ALSO. LWTRAN1C.8
CLL AUTHOR: STEPHANIE WOODWARD 19-10-94 LWTRAN1C.9
CLL (BASED ON UM CODE WRITTEN BY WILLIAM INGRAM) LWTRAN1C.10
CLL VERSION 3.4 LWTRAN1C.11
CLL LWTRAN1C.12
CLL LWTRAN1C.13
CLL IT CALCULATES CLEAR-SKY TRANSMISSIVITIES IN EACH OF THE NBANDS LWTRAN1C.14
CLL LONGWAVE SPECTRAL BANDS (AND, OPTIONALLY, ADDITIONAL DIAGNOSTIC LWTRAN1C.15
CLL ONES) FROM THE PATHLENGTHS FOR EACH EFFECTIVE ABSORBING GAS. LWTRAN1C.16
CLL (WHERE THE ABSORPTION BY A GAS INCLUDES TERMS WITH DIFFERENT LWTRAN1C.17
CLL PATHLENGTH SCALING, LIKE WATER VAPOUR LINE & CONTINUUM, THEY ARE LWTRAN1C.18
CLL DIFFERENT GASES AS FAR AS LWTRAN IS CONCERNED.) IT USES LOOK-UP LWTRAN1C.19
CLL TABLES DERIVED FROM LINE DATA AS DESCRIBED BY SLINGO AND WILDERSPIN LWTRAN1C.20
CLL (APRIL 1986, QUART.J.R.MET.SOC., 112, 472, 371-386), OR UMDP 23, LWTRAN1C.21
CLL WHICH INCORPORATE A FULL ANGULAR INTEGRATION. INTERPOLATION IS LWTRAN1C.22
CLL LOGARITHMIC IN THE PATHLENGTH, WITH VALUES AT HALF-DECADE INTERVALS LWTRAN1C.23
CLL FROM 10**-9 TO 10**3 KG/M2. LWTRAN1C.24
CLL OFFLINE DOCUMENTATION IS IN UMDP 23. LWTRAN1C.25
C GSS3F402.218
CLL Model Modification history from model version 3.0: GSS3F402.219
CLL version Date GSS3F402.220
CLL 4.2 Sept.96 T3E migration: *DEF CRAY removed; GSS3F402.221
CLL dynamic allocation no longer *DEF controlled; GSS3F402.222
CLL cray HF functions removed. GSS3F402.223
CLL S.J.Swarbrick GSS3F402.224
C*L LWTRAN1C.26
SUBROUTINE LWTRAN (PATH, TRTAB, DTRTAB, 6LWTRAN1C.27
& L, GSS3F402.225
& TRANS) LWTRAN1C.31
C* LWTRAN1C.32
*CALL LWNBANDS 
LWTRAN1C.33
*CALL LWNGASES LWTRAN1C.34
*CALL LWGSINBS LWTRAN1C.35
*CALL LWKCONT LWTRAN1C.36
*CALL LWNTRANS LWTRAN1C.37
*CALL LWNLKUPS LWTRAN1C.38
*CALL LWTABLE LWTRAN1C.39
C*L LWTRAN1C.45
INTEGER!, INTENT(IN) :: LWTRAN1C.47
& L ! NUMBER OF POINTS LWTRAN1C.48
REAL!, INTENT(IN) :: LWTRAN1C.50
& PATH (L,NGASUS,NBANDS), ! SCALED PATHLENGTHS FOR EACH GAS LWTRAN1C.51
& TRTAB(IT,NBANDS,NSCGMX), ! TRANSMISSIVITY LOOK-UP TABLE LWTRAN1C.52
& DTRTAB(IT,NBANDS,NSCGMX) ! TABLE OF DIFFERENCES LWTRAN1C.53
REAL!, INTENT(OUT) :: LWTRAN1C.54
& TRANS(L,NBANDS) ! TRANSMISSIVITIES LWTRAN1C.55
C* LWTRAN1C.56
CL ! NO EXTERNAL ROUTINES CALLED LWTRAN1C.57
C LWTRAN1C.63
REAL RLNR10, ! NDEC/LN(10) LWTRAN1C.64
& TGAS, ! TRANSMISSIVITY DUE TO A SINGLE "GAS" LWTRAN1C.65
& Y(L,NBANDS) ! USED IN THE INTERPOLATION LWTRAN1C.66
INTEGER JTRANS, GAS, J, ! LOOP OVER TRANSMISSIVITY, GAS, POINT LWTRAN1C.67
& BAND, ! AND BAND LWTRAN1C.68
& I(L,NBANDS) ! INT(Y) LWTRAN1C.69
& ,NCONT ! LOOP OVER CONTINUA LWTRAN1C.70
C LWTRAN1C.71
RLNR10 = REAL(NDEC) / LOG(10.) ! CANNOT PUT THIS IN A LWTRAN1C.72
C ! PARAMETER STATEMENT IN FORTRAN77, BUT THE CRAY COMPILER'S LWTRAN1C.73
C ! OPTIMIZER WILL MAKE IT HAVE THE SAME EFFECT AS IF IT WERE. LWTRAN1C.74
C LWTRAN1C.75
C ! FIRST, INITIALIZE THE TRANSMISSIVITIES TO 1 - WE WILL ASSUME LWTRAN1C.76
C ! RANDOM OVERLAP OF LINES OF DIFFERENT GASES, SO THAT THE TOTAL LWTRAN1C.77
C ! TRANSMISSIVITY IN EACH BAND IS THE PRODUCT OF THE LWTRAN1C.78
C ! TRANSMISSIVITIES FOR THE INDIVIDUAL GASES. LWTRAN1C.79
C LWTRAN1C.80
C ! INITIALISE OFFSET & START OF TABLE LWTRAN1C.81
DO 710 GAS=1,NSCGUS LWTRAN1C.82
OFFSET(GAS)=1.-LOG10S(GAS)*NDEC LWTRAN1C.83
ZSTART(GAS)=10.**LOG10S(GAS) LWTRAN1C.84
710 CONTINUE LWTRAN1C.85
C LWTRAN1C.86
C ! INITIALIZE THE TRANSMISSIVITIES TO 1 - WE WILL ASSUME LWTRAN1C.87
C ! RANDOM OVERLAP OF LINES OF DIFFERENT GASES, SO THAT THE TOTAL LWTRAN1C.88
C ! TRANSMISSIVITY IN EACH BAND IS THE PRODUCT OF THE LWTRAN1C.89
C ! TRANSMISSIVITIES FOR THE INDIVIDUAL GASES. LWTRAN1C.90
LWTRAN1C.91
DO 1 JTRANS=1, NBANDS LWTRAN1C.92
CFPP$ SELECT(CONCUR) LWTRAN1C.93
DO 1 J=1, L LWTRAN1C.94
TRANS(J,JTRANS) = 1. LWTRAN1C.95
1 CONTINUE LWTRAN1C.96
C LWTRAN1C.97
C ! LOOP THROUGH BANDS AND LWTRAN1C.98
C ! LOOP THROUGH THOSE EFFECTIVE GASES WHICH USE LOOK-UP TABLES LWTRAN1C.99
C LWTRAN1C.100
DO 2 JTRANS = 1,NBANDS LWTRAN1C.101
C LWTRAN1C.102
DO 210 GAS = 1,nscgus LWTRAN1C.103
IF (GSINBS(GAS,JTRANS).EQ.1) THEN LWTRAN1C.104
CFPP$ SELECT(CONCUR) LWTRAN1C.105
DO 20 J=1, L LWTRAN1C.106
Y(J,JTRANS)=LOG(PATH(J,GAS,JTRANS))*RLNR10+OFFSET(GAS) LWTRAN1C.110
C OFFSET ALLLOWS FOR THE START-POINT OF THE TABLES (SAME FOR ALL GASES). LWTRAN1C.112
C IT COULD BE REMOVED BY GIVING (D)TRTAB DIFFERENT BOUNDS, BUT MY LWTRAN1C.113
I(J,JTRANS) = INT(Y(J,JTRANS)) LWTRAN1C.114
Y(J,JTRANS) = Y(J,JTRANS) - REAL(I(J,JTRANS)) LWTRAN1C.115
IF (I(J,JTRANS).GT.IT) I(J,JTRANS) = IT LWTRAN1C.116
C LWTRAN1C.117
IF (I(J,JTRANS).GE.1) THEN LWTRAN1C.118
TGAS = TRTAB(I(J,JTRANS),JTRANS,GAS) + LWTRAN1C.119
& Y(J,JTRANS)*DTRTAB(I(J,JTRANS),JTRANS,GAS) LWTRAN1C.120
ELSE LWTRAN1C.121
TGAS = LWTRAN1C.122
& 1.-(1.-TRTAB(1,JTRANS,GAS))*PATH(J,GAS,JTRANS)/ZSTART(GAS) LWTRAN1C.123
ENDIF LWTRAN1C.124
! ASSUME RANDOM OVERLAP OF LINES OF DIFFERENT GASES, SO THAT LWTRAN1C.125
! THE TOTAL TRANSMISSIVITY IS THE PRODUCT OF THE LWTRAN1C.126
! TRANSMISSIVITIES FOR THE INDIVIDUAL GASES: LWTRAN1C.127
TRANS(J,JTRANS) = TRANS(J,JTRANS) * TGAS LWTRAN1C.128
20 CONTINUE LWTRAN1C.129
END IF LWTRAN1C.130
210 CONTINUE LWTRAN1C.131
C LWTRAN1C.132
C LWTRAN1C.133
C LWTRAN1C.134
2 CONTINUE LWTRAN1C.135
C LWTRAN1C.136
C ! CFC IN WEAK LIMIT SO JUST USE EXPONENTIALS LWTRAN1C.137
C ! AGAIN, TRANSMISSIVITIES JUST MULTIPLY: LWTRAN1C.138
C LWTRAN1C.139
DO 40 JTRANS = 1,NBANDS LWTRAN1C.140
IF (GSINBS(NCFC11,JTRANS).EQ.1) THEN LWTRAN1C.155
DO 43 J = 1,L LWTRAN1C.156
TRANS(J,JTRANS) = TRANS(J,JTRANS)*EXP(KCFC11(JTRANS) LWTRAN1C.157
& *PATH(J,NCFC11,JTRANS)) LWTRAN1C.158
43 CONTINUE LWTRAN1C.159
END IF LWTRAN1C.160
IF (GSINBS(NCFC12,JTRANS).EQ.1) THEN LWTRAN1C.161
DO 44 J = 1,L LWTRAN1C.162
TRANS(J,JTRANS) = TRANS(J,JTRANS)*EXP(KCFC12(JTRANS) LWTRAN1C.163
& *PATH(J,NCFC12,JTRANS)) LWTRAN1C.164
44 CONTINUE LWTRAN1C.165
END IF LWTRAN1C.166
40 CONTINUE LWTRAN1C.168
C LWTRAN1C.169
RETURN LWTRAN1C.170
END LWTRAN1C.171
C LWTRAN1C.172
C LWTRAN1C.173
C LWTRAN1C.174
SUBROUTINE LWLKIN (LWLUT) 2LWTRAN1C.175
C LWTRAN1C.176
*CALL LWNBANDS LWTRAN1C.177
*CALL LWNGASES LWTRAN1C.178
*CALL LWNLKUPS LWTRAN1C.179
C LWTRAN1C.180
REAL!, INTENT(OUT) LWTRAN1C.181
& LWLUT(IT,NBANDS,NSCGMX,2) LWTRAN1C.182
REAL TRTAB(IT,NBANDS,NSCGMX) LWTRAN1C.183
INTEGER JTRANS, GAS, J, ! LOOP OVER TRANSMISSIVITY, GAS & POINT LWTRAN1C.184
& NUNUSE ! NUMBER OF UNUSED ELEMENTS IN TRTAB LWTRAN1C.185
*CALL LWLKUPNU LWTRAN1C.186
PARAMETER (NUNUSE = 33*IT) LWTRAN1C.187
C ! INITIALIZE UNUSED PARTS TO ONE TO PREVENT INDEF PROBLEMS LWTRAN1C.188
C ! ( 1. BECAUSE THAT IS TRANSMISSIVITY IF NO GAS PRESENT ) LWTRAN1C.189
DATA ((TRTAB(J,JTRANS,NCO2),J=1,IT),JTRANS=1,2), LWTRAN1C.190
& (TRTAB(J, 4 ,NCO2),J=1,IT) , LWTRAN1C.191
& ((TRTAB(J,JTRANS,NCO2),J=1,IT),JTRANS=7,9), LWTRAN1C.192
& ((TRTAB(J,JTRANS,NO3),J=1,IT),JTRANS=1,2), LWTRAN1C.193
& ((TRTAB(J,JTRANS,NO3),J=1,IT),JTRANS=4,5), LWTRAN1C.194
& ((TRTAB(J,JTRANS,NO3),J=1,IT),JTRANS=7,9), LWTRAN1C.195
& ((TRTAB(J,JTRANS,NN2O),J=1,IT),JTRANS=1,2), LWTRAN1C.196
& ((TRTAB(J,JTRANS,NN2O),J=1,IT),JTRANS=4,6), LWTRAN1C.197
& (TRTAB(J, 9 ,NN2O),J=1,IT) , LWTRAN1C.198
& ((TRTAB(J,JTRANS,NCH4),J=1,IT),JTRANS=1,7), LWTRAN1C.199
c & (TRTAB(J, 9 ,NCH4),J=1,IT) , LWTRAN1C.200
& (TRTAB(J, 9 ,NCH4),J=1,IT), LWTRAN1C.201
& (TRTAB(J, 1 ,NH2OS),J=1,IT) , LWTRAN1C.202
& (TRTAB(J, 9 ,NH2OS),J=1,IT) , LWTRAN1C.203
c & ((TRTAB(J,JTRANS,NH2OS),J=1,IT),JTRANS=8,9), LWTRAN1C.204
& (TRTAB(J, 9 ,NH2OF),J=1,IT) , LWTRAN1C.205
& ((TRTAB(J,JTRANS,NH2OF),J=1,IT),JTRANS=5,7) LWTRAN1C.206
& / NUNUSE*1.0/ LWTRAN1C.207
C LWTRAN1C.208
DO 1 GAS=1, NSCGUS LWTRAN1C.209
DO 1 JTRANS=1, NBANDS LWTRAN1C.210
DO 1 J=1, IT LWTRAN1C.211
LWLUT(J,JTRANS,GAS,1) = TRTAB(J,JTRANS,GAS) LWTRAN1C.212
1 CONTINUE LWTRAN1C.213
C LWTRAN1C.214
DO 2 GAS=1, NSCGUS LWTRAN1C.215
DO 2 JTRANS=1, NBANDS LWTRAN1C.216
DO 2 J=1, IT-1 LWTRAN1C.217
LWLUT(J,JTRANS,GAS,2) = LWTRAN1C.218
& LWLUT(J+1,JTRANS,GAS,1) - LWLUT(J,JTRANS,GAS,1) LWTRAN1C.219
2 CONTINUE LWTRAN1C.220
C LWTRAN1C.221
C ! SET THE LAST ELEMENT FOR EACH GAS AND BAND TO ZERO, SO THAT THE LWTRAN1C.222
C ! EXTRAPOLATION DONE FOR ANY PATHLENGTH GREATER THAN THE MAXIMUM LWTRAN1C.223
C ! CATERED FOR JUST GIVES THE GREATEST VALUE IN TRTAB. LWTRAN1C.224
C LWTRAN1C.225
DO 3 GAS=1, NSCGUS LWTRAN1C.226
DO 3 JTRANS=1, NBANDS LWTRAN1C.227
LWLUT(IT,JTRANS,GAS,2) = 0. LWTRAN1C.228
3 CONTINUE LWTRAN1C.229
C LWTRAN1C.230
RETURN LWTRAN1C.231
END LWTRAN1C.232
*ENDIF A02_1C LWTRAN1C.233