*IF DEF,A01_1A,OR,DEF,A01_1B,OR,DEF,A01_2A,OR,DEF,A01_2B AWI3F402.1
C ******************************COPYRIGHT****************************** GTS2F400.10063
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10064
C GTS2F400.10065
C Use, duplication or disclosure of this code is subject to the GTS2F400.10066
C restrictions as set forth in the contract. GTS2F400.10067
C GTS2F400.10068
C Meteorological Office GTS2F400.10069
C London Road GTS2F400.10070
C BRACKNELL GTS2F400.10071
C Berkshire UK GTS2F400.10072
C RG12 2SZ GTS2F400.10073
C GTS2F400.10074
C If no contract has been raised with this copy of the code, the use, GTS2F400.10075
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10076
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10077
C Modelling at the above address. GTS2F400.10078
C ******************************COPYRIGHT****************************** GTS2F400.10079
C GTS2F400.10080
CLL Subroutines SWTRAN, SWLKIN --------------------------------------- SWTRAN1A.3
CLL SWTRAN1A.4
CLL Purpose : SWTRAN1A.5
CLL It calculates shortwave transmissivities for each band for a SWTRAN1A.6
CLL particular set of pathlengths of the absorbing gases. SWTRAN1A.7
CLL SWTRAN1A.8
CLL Before SWTRAN is CALLed (normally via SWRAD and SWMAST), SWLKIN SWTRAN1A.9
CLL must be CALLed to initialize LUT, which contains the transmissivity SWTRAN1A.10
CLL and difference-of-transmissivity look-up tables. (Some other SWTRAN1A.11
CLL numbers used to access them are set by SWMAST and passed in in SWTRAN1A.12
CLL TTEC: a single array is used for what are logically 3 types of SWTRAN1A.13
CLL quantity to reduce CALLing overheads.) SWTRAN1A.14
CLL SWTRAN1A.15
CLL It is intended to be easily modified to perform also some of the SWTRAN1A.16
CLL functions of D23 (radiation diagnostics). SWTRAN1A.17
CLL Suitable for single column model use. SWTRAN1A.18
CLL SWTRAN1A.19
CLL Author: William Ingram SWTRAN1A.20
CLL SWTRAN1A.21
CLL Model Modification history from model version 3.0: SWTRAN1A.22
CLL version Date SWTRAN1A.23
CLL 4.2 Sept.96 T3E migration: *DEF CRAY removed; GSS3F402.1
CLL *DEF T3E used for T3E library functions; GSS3F402.2
CLL dynamic allocation no longer *DEF controlled; GSS3F402.3
CLL CRAY HF functions replaced by T3E fast vector GSS3F402.4
CLL functions. S.J.Swarbrick GSS3F402.5
CLL SWTRAN1A.24
CLL Programming standard : SWTRAN1A.25
CLL It conforms to standard A of UMDP 4 (version 3, 07/9/90), and SWTRAN1A.26
CLL includes no features deprecated in 8X. SWTRAN1A.27
CLL If *DEF CRAY is off, the code is standard FORTRAN 77 except for SWTRAN1A.28
CLL having ! comments (it then sets the "vector length" to be 1) but SWTRAN1A.29
CLL otherwise it includes CRAY automatic arrays also. SWTRAN1A.30
CLL SWTRAN1A.31
CLL Logical components covered : P234 SWTRAN1A.32
CLL (interaction of shortwave radiation with the atmosphere) SWTRAN1A.33
CLL SWTRAN1A.34
CLL Project task : SWTRAN1A.35
CLL SWTRAN1A.36
CLL External documentation: SWTRAN1A.37
CLL Offline documentation in UMDP 23, particularly Appendix 2. SWTRAN1A.38
CLL SWTRAN1A.39
CLLEND ---------------------s------------------------------------------- GSS3F402.6
C*L SWTRAN1A.41
SUBROUTINE SWTRAN (PATH, TTEC, TRTAB, DTRTAB, 15SWTRAN1A.42
& L, GSS3F402.7
& TRANS) SWTRAN1A.46
C* SWTRAN1A.47
*CALL SWNGASES 
SWTRAN1A.48
*CALL SWNBANDS SWTRAN1A.49
*CALL SWNTRANS SWTRAN1A.50
*CALL SWLKUPPA SWTRAN1A.51
INTEGER!, INTENT (IN) SWTRAN1A.53
& L ! Number of points SWTRAN1A.54
C*L SWTRAN1A.60
REAL!, INTENT (IN) SWTRAN1A.61
& PATH(L,NGASES), ! Total pathlength for each gas SWTRAN1A.62
& TRTAB(NLKUPS,NTRANS,NGASES), SWTRAN1A.63
C ! Look-up tables for transmissivities for each gas and of SWTRAN1A.64
C ! differences of their successive elements. SWTRAN1A.65
& DTRTAB(NLKUPS,NTRANS,NGASES), SWTRAN1A.66
& TTEC(NGASES,NTRANS+2) SWTRAN1A.67
REAL!, INTENT (OUT) SWTRAN1A.68
& TRANS(L,NBANDS) ! Transmissivities in each band SWTRAN1A.69
C ! Note that the transmissivities are the fraction of the total SWTRAN1A.70
C ! incoming solar to be transmitted in each band, i.e. the SWTRAN1A.71
C ! transmissivity for the band alone multiplied by the fraction SWTRAN1A.72
C ! of the solar constant in the band. This simplifies SWMAST. SWTRAN1A.73
C ! SWTRAN1A.74
C ! SWTRAN has 2 dynamically allocated workspace arrays, no EXTERNAL SWTRAN1A.75
C ! calls and no significant structure - just nested loops. SWTRAN1A.76
C* SWTRAN1A.77
*CALL SWFSCIEB SWTRAN1A.78
*CALL SWFSTBND SWTRAN1A.79
C GSS3F402.8
INTEGER I(L) ! Index for which element of the SWTRAN1A.81
C ! transmissivity look-up table is used SWTRAN1A.82
REAL TR1GAS, ! Transmissivity considering only 1 gas SWTRAN1A.83
& Y(L) ! Scaled log(pathlength): its integer SWTRAN1A.84
C ! part is I and its fractional part gives the fraction to move SWTRAN1A.85
C ! towards the next entry in the look-up table. SWTRAN1A.86
INTEGER BAND, GAS, J ,K ! Loopers over bands, gases and points GSS3F402.9
! Local workspace GSS3F402.10
REAL LOGPATH(L,NGASES) GSS3F402.11
C SWTRAN1A.88
C ! Initialize TRANS from FSCIEB: SWTRAN1A.89
C SWTRAN1A.90
DO 100 BAND=1, NBANDS SWTRAN1A.91
Cfpp$ Select(CONCUR) SWTRAN1A.92
DO 100 J=1, L SWTRAN1A.93
TRANS(J,BAND) = FSCIEB(BAND) SWTRAN1A.94
100 CONTINUE SWTRAN1A.95
C SWTRAN1A.96
C ! Find and combine the TR1GAS terms: SWTRAN1A.97
C SWTRAN1A.98
*IF DEF,VECTLIB PXVECTLB.145
! Use fast t3e vector function GSS3F402.13
call alog_v(l*ngases, path, logpath) GSS3F402.14
*ELSE GSS3F402.15
DO J=1,L GSS3F402.16
DO K=1,NGASES GSS3F402.17
logpath(j,k)=log(path(j,k)) GSS3F402.18
END DO GSS3F402.19
END DO GSS3F402.20
*ENDIF GSS3F402.21
GSS3F402.22
DO 1000 GAS=1, NGASES SWTRAN1A.99
Cfpp$ Select(CONCUR) SWTRAN1A.100
DO 101 J=1, L SWTRAN1A.101
Y(J) = TTEC(GAS,NTRANS+1) SWTRAN1A.102
& + TTEC(GAS,NTRANS+2) * LOGPATH(J,GAS) GSS3F402.23
I(J) = INT(Y(J)) SWTRAN1A.108
Y(J) = Y(J) - REAL(I(J)) SWTRAN1A.109
C ! For very large pathlengths, use maximum values in the table: SWTRAN1A.110
I(J) = MIN(I(J),NLKUPS) SWTRAN1A.111
101 CONTINUE SWTRAN1A.112
DO 1000 BAND=FSTBAND(GAS), LSTBAND(GAS) SWTRAN1A.113
Cfpp$ Select(CONCUR) SWTRAN1A.114
DO 1000 J=1, L SWTRAN1A.115
IF ( I(J) .GT. 0 ) THEN SWTRAN1A.116
C (Equivalent to IF ( PATH(J,GAS) .GT. RMNPTH(GAS) ) but safer.) SWTRAN1A.117
TR1GAS = TRTAB(I(J),BAND,GAS) + Y(J) * DTRTAB(I(J),BAND,GAS) SWTRAN1A.118
ELSE SWTRAN1A.119
C ! For very small pathlengths, absorption goes linearly to 0 SWTRAN1A.120
TR1GAS = 1. - PATH(J,GAS) * TTEC(GAS,BAND) SWTRAN1A.121
ENDIF SWTRAN1A.122
C ! We assume random overlap of different gases' absorption SWTRAN1A.123
C ! lines, so that their transmissivities just multiply: SWTRAN1A.124
TRANS(J,BAND) = TRANS(J,BAND) * TR1GAS SWTRAN1A.125
1000 CONTINUE SWTRAN1A.126
C SWTRAN1A.127
RETURN SWTRAN1A.128
END SWTRAN1A.129
SUBROUTINE SWLKIN (SWLUT) 2SWTRAN1A.130
*CALL SWNBANDS SWTRAN1A.131
*CALL SWNGASES SWTRAN1A.132
*CALL SWNTRANS SWTRAN1A.133
*CALL SWLKUPPA SWTRAN1A.134
REAL!, INTENT(OUT) SWTRAN1A.135
& SWLUT(NLKUPS,NTRANS,NGASES,2) SWTRAN1A.136
REAL TRTAB(NLKUPS,NTRANS,NGASES) SWTRAN1A.137
C SWTRAN1A.138
INTEGER JTRANS, GAS, J ! Loop over transmissivity, gas & ... SWTRAN1A.139
*CALL SWLKUPNU SWTRAN1A.140
C SWTRAN1A.141
DO 1 GAS=1, NGASES SWTRAN1A.142
DO 1 JTRANS=1, NTRANS SWTRAN1A.143
DO 1 J=1, NLKUPS SWTRAN1A.144
SWLUT(J,JTRANS,GAS,1) = TRTAB(J,JTRANS,GAS) SWTRAN1A.145
1 CONTINUE SWTRAN1A.146
C SWTRAN1A.147
DO 2 GAS=1, NGASES SWTRAN1A.148
DO 2 JTRANS=1, NTRANS SWTRAN1A.149
DO 2 J=1, NLKUPS - 1 SWTRAN1A.150
SWLUT(J,JTRANS,GAS,2) = SWTRAN1A.151
& TRTAB(J+1,JTRANS,GAS) - TRTAB(J,JTRANS,GAS) SWTRAN1A.152
2 CONTINUE SWTRAN1A.153
C SWTRAN1A.154
C ! Set the last element for each gas and band to zero, so that the SWTRAN1A.155
C ! extrapolation done for any pathlength greater than the maximum SWTRAN1A.156
C ! catered for just gives the greatest value in TRTAB. SWTRAN1A.157
C SWTRAN1A.158
DO 3 GAS=1, NGASES SWTRAN1A.159
DO 3 JTRANS=1, NTRANS SWTRAN1A.160
SWLUT(NLKUPS,JTRANS,GAS,2) = 0. SWTRAN1A.161
3 CONTINUE SWTRAN1A.162
C SWTRAN1A.163
RETURN SWTRAN1A.164
END SWTRAN1A.165
*ENDIF DEF,A01_1A,OR,DEF,A01_1B,OR,DEF,A01_2A SWTRAN1A.166