*IF DEF,A01_1A SWMAST1A.2
C ******************************COPYRIGHT****************************** GTS2F400.9973
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.9974
C GTS2F400.9975
C Use, duplication or disclosure of this code is subject to the GTS2F400.9976
C restrictions as set forth in the contract. GTS2F400.9977
C GTS2F400.9978
C Meteorological Office GTS2F400.9979
C London Road GTS2F400.9980
C BRACKNELL GTS2F400.9981
C Berkshire UK GTS2F400.9982
C RG12 2SZ GTS2F400.9983
C GTS2F400.9984
C If no contract has been raised with this copy of the code, the use, GTS2F400.9985
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.9986
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.9987
C Modelling at the above address. GTS2F400.9988
C ******************************COPYRIGHT****************************** GTS2F400.9989
C GTS2F400.9990
CLL Subroutine SWMAST ---------------------------------------------- SWMAST1A.3
CLL SWMAST1A.4
CLL Purpose : SWMAST1A.5
CLL This is the version with COMPATHS off. SWMAST1A.6
CLL It is the top-level plug-compatible routine in component P234 SWMAST1A.7
CLL (interaction of shortwave radiation with the atmosphere) SWMAST1A.8
CLL It also performs some of the functios of SWMAST1A.9
CLL D23 (radiation diagnostics). SWMAST1A.10
CLL It acts as the master routine for P234, assembling the net solar SWMAST1A.11
CLL flux (normalized by the incoming insolation at the top of the SWMAST1A.12
CLL atmosphere) by considering the various beams and calling various SWMAST1A.13
CLL specialized routines. SWMAST1A.14
CLL Before SWMAST is called, SWLKIN (in deck SWTRAN) must be CALLed to SWMAST1A.15
CLL initialize LUT for SWTRAN. SWMAST1A.16
CLL Release 2.8 of the UM uses different surface albedos SWMAST1A.17
CLL for direct and diffuse light, which in turn means that two SWMAST1A.18
CLL quantities that SWRAD used to calculate from FLUX and the surface SWMAST1A.19
CLL albedos now have to be found here - TDSS and DSFLUX. SWMAST1A.20
CLL William Ingram 25/9/92 SWMAST1A.21
CLL SWMAST1A.22
CLL Author: William Ingram SWMAST1A.23
CLL SWMAST1A.24
CLL Model Modification history from model version 3.0: SWMAST1A.25
CLL version Date SWMAST1A.26
CLL 4.2 Sept.96 T3E migration: *DEF CRAY removed; GSS2F402.1
CLL *DEF T3E used for T3E library functions; GSS2F402.2
CLL dynamic allocation no longer *DEF controlled. GSS2F402.3
CLL S.J.Swarbrick GSS2F402.4
CLL SWMAST1A.27
CLL GSS2F402.5
CLL Programming standard : SWMAST1A.28
CLL It conforms to standard A of UMDP 4 (version 3, 07/9/90), and SWMAST1A.29
CLL includes no features deprecated in 8X. SWMAST1A.30
CLL If *DEF CRAY is off, the code is standard FORTRAN 77 except for SWMAST1A.31
CLL having ! comments (it then sets the "vector length" to be 1) but SWMAST1A.32
CLL otherwise it includes CRAY automatic arrays also. SWMAST1A.33
CLL SWMAST1A.34
CLL Logical components covered : P234, D3 SWMAST1A.35
CLL SWMAST1A.36
CLL Project task : P23 SWMAST1A.37
CLL SWMAST1A.38
CLL External documentation: UMDP 23 SWMAST1A.39
CLL SWMAST1A.40
CLLEND ----------------------------------------------------------------- SWMAST1A.41
C*L SWMAST1A.42
SUBROUTINE SWMAST (H2O, CO2, O3, PSTAR, AB, BB, LCA, LCCWP, 2,28SWMAST1A.43
& LRE, CCA, CCCWP, CRE, CCB, CCT, COSZ, TSA, DTSA, TRTAB, SWMAST1A.44
& CSOSDI, CSOSON, NSSB1, NSS1ON, TDSS, TDSSON, SWMAST1A.45
& CSSSD, CSSSDO, CSSSU, CSSSUO, LCAAR, LCAARO, LCAARL, LCAARB, SWMAST1A.46
& LCAAF, LCAAFO, LCAAFL, LCAAFB, CCAAR, CCAARO, CCAARB, CCAAF, SWMAST1A.47
& CCAAFO, CCAAFB, SWMAST1A.48
& L2, NLEVS, NCLDS, GSS2F402.6
& NWET, NOZONE, L1, L3, DSFLUX, FLUX) SWMAST1A.52
C* SWMAST1A.53
CL ! SWMAST has 4 EXTERNAL calls SWMAST1A.54
EXTERNAL SWTRAN, SWCLOP, SWMSAL, SWPTSC SWMAST1A.55
*CALL SWNBANDS 
SWMAST1A.56
*CALL SWNGASES SWMAST1A.57
*CALL SWNTRANS SWMAST1A.58
*CALL SWLKUPPA SWMAST1A.59
INTEGER!, INTENT (IN) SWMAST1A.65
& L2, ! Number of points to be treated SWMAST1A.67
& NLEVS, ! Number of levels SWMAST1A.68
& NCLDS, ! Number of possibly cloudy ones SWMAST1A.69
& NWET, ! Number of levels with moisture SWMAST1A.71
& NOZONE, ! Number of levels with ozone SWMAST1A.72
C ! Need 0 =< NCLDS < NLEVS, 0 =< NWET =< NLEVS, 0 < NOZONE =< NLEVS SWMAST1A.73
& L1, ! First dimension of input arrays SWMAST1A.74
& L3, ! First dimension of flux output SWMAST1A.75
& CCB(L1), CCT(L1) SWMAST1A.76
C ! Convective cloud base & top, counting down from the top, and in SWMAST1A.77
C ! terms of lowest and highest full layers occupied. Thus SWMAST1A.78
C ! CCT(SW)=NLEVS+2-CCT(LW), CCB(SW)=NLEVS+1-CCB(LW), SWMAST1A.79
C ! and a one-layer-thick con cloud has CCB=CCT. SWMAST1A.80
REAL!, INTENT (IN) SWMAST1A.81
& H2O(L1,NWET), CO2, ! Mass mixing ratio (mK in UMDP SWMAST1A.82
& O3(L1,NOZONE), ! 23) of each absorbing gas SWMAST1A.83
& COSZ(L1), ! Cos(solar zenith angle) SWMAST1A.84
& PSTAR(L1), ! Surface pressure SWMAST1A.85
& AB(NLEVS+1), BB(NLEVS+1), ! As and Bs at layer boundaries SWMAST1A.86
& LCA(L1,NLEVS-NCLDS+1:NLEVS),! Layer cloud amount, condensed SWMAST1A.87
& LCCWP(L1,NLEVS-NCLDS+1:NLEVS),! water path and effective SWMAST1A.88
& LRE(L1,NLEVS-NCLDS+1:NLEVS),! cloud droplet radius. SWMAST1A.89
& CCA(L1), ! The same for convective cloud. SWMAST1A.90
& CCCWP(L1), ! SWMAST1A.91
& CRE(L1), ! SWMAST1A.92
& TSA(L1,NBANDS,2), ! True surface albedo - mean over SWMAST1A.93
C ! the whole grid-box for each band for direct & then diffuse light SWMAST1A.94
& DTSA(L1,NBANDS,2), ! True surface albedo - SWMAST1A.95
C ! different value for some specific part of the grid-box where SWMAST1A.96
C ! separate calculations are wanted. SWMAST1A.97
& TRTAB(NLKUPS,NTRANS,NGASES,2) SWMAST1A.98
C ! Look-up tables of transmissivities for each gas and of SWMAST1A.99
C ! differences of their successive elements. SWMAST1A.100
LOGICAL!, INTENT(IN) SWMAST1A.101
& CSOSON, NSS1ON ! Are CSOSDI and NSSB1 wanted ? SWMAST1A.102
& , CSSSDO, CSSSUO ! & are CSSSD and CSSSU, SWMAST1A.103
& , LCAARO, LCAAFO ! LCAAR and LCAAF, SWMAST1A.104
& , CCAARO, CCAAFO ! CCAAR and CCAAF ? SWMAST1A.105
& , LCAARL(NCLDS), LCAARB(NBANDS), LCAAFL(NCLDS) SWMAST1A.106
& , LCAAFB(NBANDS), CCAARB(NBANDS), CCAAFB(NBANDS) SWMAST1A.107
C ! If L/C AA R/L are wanted, on which (levels and) bands ? SWMAST1A.108
C ! (The levels are listed from the surface up in these.) SWMAST1A.109
& , TDSSON ! & is TDSS ? SWMAST1A.110
REAL!, INTENT (OUT) SWMAST1A.111
& FLUX(L3,0:NLEVS) ! Net downward solar flux, as a SWMAST1A.112
C ! fraction of the incoming solar SWMAST1A.113
& , DSFLUX(L3) ! Net downward flux at the SWMAST1A.114
C ! surface where DTSA applies SWMAST1A.115
& , CSOSDI(L1) ! Diagnosed clear-sky outgoing SW SWMAST1A.116
& , NSSB1(L1) ! and net surface flux in band 1 SWMAST1A.117
& , CSSSD(L1) ! Clear-sky total downward & SWMAST1A.118
& , CSSSU(L1) ! upward SW flux at the surface SWMAST1A.119
& , LCAAR(L3,*) ! Layer/Convective Cloud Amount SWMAST1A.120
& , LCAAF(L3,*) ! * Albedo to diRect and SWMAST1A.121
& , CCAAR(L3,*) ! diFfuse light (set to zero SWMAST1A.122
& , CCAAF(L3,*) ! at night points) SWMAST1A.123
C ! for the area DTSA applies to SWMAST1A.124
& , TDSS(L1) ! Total downward solar flux at SWMAST1A.125
C ! the surface (counting multiply reflected light multiply). SWMAST1A.126
C SWMAST1A.127
C* SWMAST1A.128
CL ! SWMAST has lots of dynamically allocated workspace: SWMAST1A.130
CL ! L2* SWMAST1A.131
CL ! ( NGASES*(NCLDS+NLEVS+2) +NBANDS*(2*NCLDS+2NCLDS*NLEVS+8)+2 ) SWMAST1A.132
REAL PATH(L2,NGASES,NLEVS-NCLDS:NLEVS), ! Scaled gas pathlengths SWMAST1A.134
C ! for the total paths to the current layer for the direct beam SWMAST1A.135
C ! and the light made diffuse in each cloudy layer (indexed by SWMAST1A.136
C ! NLEVS-NCLDS and FSTCLD to NLEVS respectively). SWMAST1A.137
& GREY(L2,NBANDS,NLEVS-NCLDS:NLEVS+NCLDS), SWMAST1A.138
C ! Grey factor for each beam and band (fraction of the incoming SWMAST1A.139
C ! insolation in that band which would be in that beam at the SWMAST1A.140
C ! current level, allowing for clouds but not gaseous absorption). SWMAST1A.141
C ! The last dimension indexes the direct beam (NLEVS-NLCDS), the SWMAST1A.142
C ! beams made diffuse by each layer cloud and not currently in SWMAST1A.143
C ! convective cloud (FSTCLD to NLEVS respectively), the beam made SWMAST1A.144
C ! diffuse by convective cloud (NLEVS+1 - not necessary - best SWMAST1A.145
C ! combined with what's already in NCLDS+CCT(J)+1 and then the SWMAST1A.146
C ! following shifted one back) and the beams made diffuse by each SWMAST1A.147
C ! layer cloud except the last and currently in convective cloud SWMAST1A.148
C ! (NLEVS+2 to NLEVS+NCLDS respectively). SWMAST1A.149
& RFGREY(L2,NBANDS), SWMAST1A.150
& RFPATH(L2,NGASES), SWMAST1A.151
C ! Similarly, grey factors and pathlengths for whichever SWMAST1A.152
C ! reflected beam is currently being treated. SWMAST1A.153
& DPATH(L2,NGASES,NLEVS), ! Scaled absorber pathlengths SWMAST1A.154
C ! for each layer, crossed vertically. Added up after multiplying SWMAST1A.155
C ! by terms allowing for the angular magnification, these give PATH SWMAST1A.156
& GTRANS(L2,NBANDS), ! Gaseous transmissivities SWMAST1A.157
& CTRANS(L2,NBANDS,NLEVS-NCLDS+1-1/(NCLDS+1):NLEVS,2), SWMAST1A.158
& REF(L2,NBANDS,NLEVS-NCLDS+1-1/(NCLDS+1):NLEVS,2), SWMAST1A.159
C ! Cloud transmissivity and reflectivity for direct and diffuse SWMAST1A.160
C radiation respectively. SWMAST1A.161
& CCTRANS(L2,NBANDS,2), ! The same for convective cloud SWMAST1A.162
& CCREF(L2,NBANDS,2), ! only SWMAST1A.163
& DIRFAC(L2), ! Magnification factor for the SWMAST1A.164
C ! direct beam SWMAST1A.165
& MODSA(L2,NBANDS,2), ! Surface albedo TSA modified to SWMAST1A.166
C ! allow for multiple reflections SWMAST1A.167
& DIFFTR(L2) ! See "DO 6" loop SWMAST1A.168
INTEGER J, BEAM, ! Loopers over points, beams, SWMAST1A.169
& BAND, GAS, DIRDIF, ! bands, gases, direct versus SWMAST1A.170
& LEVEL, LEVEL2, ! diffuse beam, levels, and SWMAST1A.171
& INIT ! values being initialized SWMAST1A.172
*CALL SWDIFFAC SWMAST1A.173
*CALL SWHBYA SWMAST1A.174
*CALL SWRAYSCA SWMAST1A.175
REAL TTEC(NGASES,NTRANS+2) ! Offsets & multipliers for use SWMAST1A.176
C ! finding the place in (D)TRTAB, and constant for finding SWMAST1A.177
C ! transmissivity for very small pathlengths, all used in SWTRAN. SWMAST1A.178
DATA ((TTEC(GAS,INIT), GAS=1, NGASES), INIT=NTRANS+1,NTRANS+2) SWMAST1A.179
& / 23., 57., 11.4, 2.17145, 4.3429, .86858 / SWMAST1A.180
C ! Last three values are 5,10,2/log(10). Why not put in as such SWMAST1A.181
REAL GREYNT, ! Net grey factor in current beam SWMAST1A.182
& SIF, ! Surface incoming flux in 1 band SWMAST1A.183
& MINPTH ! Mininum pathlength catered for SWMAST1A.184
C ! in the look-up table for a particular absorber. SWMAST1A.185
INTEGER LSTCLR, ! Lowest always clear layer, and SWMAST1A.186
& FSTCLD, ! highest possibly cloudy one SWMAST1A.187
& DIRECT, ! Subscript for PATH & GREY SWMAST1A.188
& OFFSET, ! Index for cloud albedo*amount SWMAST1A.189
C ! diagnostics, which SWMAST returns (potentially) compressed, SWMAST1A.190
C ! allowing just the bands or level-and-band combinations wanted to SWMAST1A.191
C ! have space allocated by STASH and be set here. Bands are in SWMAST1A.192
C ! standard order, and, following the UM standard, multi-level SWMAST1A.193
C ! data has the different levels for each band or other SWMAST1A.194
C ! "pseudo-dimension" together, running up from the surface. SWMAST1A.195
& CONCLD ! Subscript in GREY of the factor SWMAST1A.196
C ! for the beam inside convective cloud SWMAST1A.197
CL SWMAST1A.198
CL ! Section 1 SWMAST1A.199
CL ~~~~~~~~~ SWMAST1A.200
CL ! Various initialization etc. - setting up constants to address SWMAST1A.201
CL ! arrays, array TTEC to pass to SWTRAN, arrays of scaled SWMAST1A.202
CL ! pathlengths by CALLing SWPTSC, cloud optical properties using SWMAST1A.203
CL ! SWCLOP and thence modified surface albedo by CALLing SWMSAL. SWMAST1A.204
CL SWMAST1A.205
LSTCLR = NLEVS - NCLDS SWMAST1A.206
FSTCLD = LSTCLR + 1 SWMAST1A.207
CONCLD = NLEVS + NCLDS SWMAST1A.208
DIRECT = LSTCLR SWMAST1A.209
C SWMAST1A.210
DO 11 GAS=1, NGASES SWMAST1A.211
MINPTH = EXP ( (1.-TTEC(GAS,NTRANS+1)) / TTEC (GAS,NTRANS+2) ) SWMAST1A.212
DO 11 INIT=1, NTRANS SWMAST1A.213
TTEC(GAS,INIT) = ( 1.-TRTAB(1,INIT,GAS,1) )/ MINPTH SWMAST1A.214
11 CONTINUE SWMAST1A.215
C SWMAST1A.216
CL ! CALL SWPTSC to set up DPATH from the water vapour, carbon SWMAST1A.217
CL ! dioxide and ozone mixing ratios, and pressure information for SWMAST1A.218
CL ! the pressure scaling. SWMAST1A.219
C SWMAST1A.220
Cfpp$ Expand SWMAST1A.221
CALL SWPTSC (H2O, CO2, O3, PSTAR, AB, BB, SWMAST1A.222
& L2, GSS2F402.7
& NLEVS, NWET, NOZONE, L1, DPATH) SWMAST1A.226
C SWMAST1A.227
CL ! Next, set up cloud-related quantities SWMAST1A.228
C SWMAST1A.229
IF ( NCLDS.GT.0 ) THEN SWMAST1A.230
C SWMAST1A.231
CL ! First CALL to SWCLOP is for layer cloud. SWMAST1A.232
C ! Condensed water pathlength (mass per unit area), effective SWMAST1A.233
C ! radius and solar zenith angle are used to calculate their SWMAST1A.234
C ! optical properties. SWMAST1A.235
C SWMAST1A.236
Cfpp$ Expand SWMAST1A.237
CALL SWCLOP (LCCWP, LRE, COSZ, L1, L2, NCLDS, REF, CTRANS) SWMAST1A.238
C SWMAST1A.239
CL ! Multiplication by cloud cover gives the optical properties SWMAST1A.240
CL ! averaged over the grid-box (as far as layer cloud goes). SWMAST1A.241
C SWMAST1A.242
DO 12 DIRDIF=1, 2 SWMAST1A.243
DO 12 LEVEL=FSTCLD, NLEVS SWMAST1A.244
DO 12 BAND=1, NBANDS SWMAST1A.245
Cfpp$ Select(CONCUR) SWMAST1A.246
DO 12 J=1, L2 SWMAST1A.247
REF(J,BAND,LEVEL,DIRDIF) = SWMAST1A.248
& REF(J,BAND,LEVEL,DIRDIF) * LCA(J,LEVEL) SWMAST1A.249
12 CONTINUE SWMAST1A.250
C SWMAST1A.251
CL ! SWCLOP is then CALLed for convective cloud. SWMAST1A.252
Cfpp$ Expand SWMAST1A.253
CALL SWCLOP (CCCWP, CRE, COSZ, L1, L2, 1, CCREF, CCTRANS) SWMAST1A.254
C SWMAST1A.255
CL ! Then the CALL to SWMSAL. SWMAST1A.256
C ! This must come before the convective and layer cloud SWMAST1A.257
C ! reflectivities are combined, as the combination is done for SWMAST1A.258
C ! light coming down, and it would be different for light SWMAST1A.259
C ! coming up after surface reflection where there was non-zero SWMAST1A.260
C ! convective cloud more than one layer thick. SWMAST1A.261
C SWMAST1A.262
Cfpp$ Expand SWMAST1A.263
CALL SWMSAL (TSA, REF(1,1,FSTCLD,2), LCA, CCREF(1,1,2), CCA, SWMAST1A.264
& CCB, LSTCLR, SWMAST1A.265
& L2, GSS2F402.8
& L1, NBANDS, NCLDS, MODSA) SWMAST1A.269
C SWMAST1A.270
C ! Diagnose cloud amounts * albedos if they are wanted SWMAST1A.271
C SWMAST1A.272
IF ( LCAARO ) THEN SWMAST1A.273
OFFSET = 1 SWMAST1A.274
DO BAND=1, NBANDS SWMAST1A.275
DO LEVEL=NLEVS, FSTCLD, -1 SWMAST1A.276
IF ( LCAARL(NLEVS+1-LEVEL) .AND. LCAARB(BAND) ) THEN SWMAST1A.277
Cfpp$ Select(CONCUR) SWMAST1A.278
DO J=1, L2 SWMAST1A.279
LCAAR(J,OFFSET) = REF(J,BAND,LEVEL,1) SWMAST1A.280
ENDDO SWMAST1A.281
OFFSET = OFFSET + 1 SWMAST1A.282
ENDIF SWMAST1A.283
ENDDO SWMAST1A.284
ENDDO SWMAST1A.285
ENDIF SWMAST1A.286
IF ( LCAAFO ) THEN SWMAST1A.287
OFFSET = 1 SWMAST1A.288
DO BAND=1, NBANDS SWMAST1A.289
DO LEVEL=NLEVS, FSTCLD, -1 SWMAST1A.290
IF ( LCAAFL(NLEVS+1-LEVEL) .AND. LCAAFB(BAND) ) THEN SWMAST1A.291
Cfpp$ Select(CONCUR) SWMAST1A.292
DO J=1, L2 SWMAST1A.293
LCAAF(J,OFFSET) = REF(J,BAND,LEVEL,2) SWMAST1A.294
ENDDO SWMAST1A.295
OFFSET = OFFSET + 1 SWMAST1A.296
ENDIF SWMAST1A.297
ENDDO SWMAST1A.298
ENDDO SWMAST1A.299
ENDIF SWMAST1A.300
IF ( CCAARO ) THEN SWMAST1A.301
OFFSET = 1 SWMAST1A.302
DO BAND=1, NBANDS SWMAST1A.303
IF ( CCAARB(BAND) ) THEN SWMAST1A.304
Cfpp$ Select(CONCUR) SWMAST1A.305
DO J=1, L2 SWMAST1A.306
CCAAR(J,OFFSET) = CCREF(J,BAND,1) * CCA(J) SWMAST1A.307
ENDDO SWMAST1A.308
OFFSET = OFFSET + 1 SWMAST1A.309
ENDIF SWMAST1A.310
ENDDO SWMAST1A.311
ENDIF SWMAST1A.312
IF ( CCAAFO ) THEN SWMAST1A.313
OFFSET = 1 SWMAST1A.314
DO BAND=1, NBANDS SWMAST1A.315
IF ( CCAAFB(BAND) ) THEN SWMAST1A.316
Cfpp$ Select(CONCUR) SWMAST1A.317
DO J=1, L2 SWMAST1A.318
CCAAF(J,OFFSET) = CCREF(J,BAND,2) * CCA(J) SWMAST1A.319
ENDDO SWMAST1A.320
OFFSET = OFFSET + 1 SWMAST1A.321
ENDIF SWMAST1A.322
ENDDO SWMAST1A.323
ENDIF SWMAST1A.324
C SWMAST1A.325
CL ! Finally combine the convective and layer cloud SWMAST1A.326
CL ! reflectivities to get the effective layer mean reflectivity SWMAST1A.327
CL ! Recall that the layer cloud cover and water path are SWMAST1A.328
CL ! deemed to describe the fraction of the grid-box outside SWMAST1A.329
CL ! the convective cloud. SWMAST1A.330
C SWMAST1A.331
DO 13 DIRDIF=1, 2 SWMAST1A.332
DO 13 BAND=1, NBANDS SWMAST1A.333
Cfpp$ Select(CONCUR) SWMAST1A.334
DO 13 J=1, L2 SWMAST1A.335
REF(J,BAND,CCT(J),DIRDIF) = CCREF(J,BAND,DIRDIF) * CCA(J) + SWMAST1A.336
& REF(J,BAND,CCT(J),DIRDIF) * ( 1. - CCA(J) ) SWMAST1A.337
13 CONTINUE SWMAST1A.338
C SWMAST1A.339
ELSE SWMAST1A.340
C SWMAST1A.341
CL ! If there are no clouds to be treated, just copy the clear-sky SWMAST1A.342
CL ! surface albedos to be used as modified surface albedos, and SWMAST1A.343
CL ! leave the rest to the DO loop bounds. SWMAST1A.344
CL ! THIS MAY OR MAY NOT WORK - untested 29/10/90 SWMAST1A.345
C SWMAST1A.346
DO 14 DIRDIF=1, 2 SWMAST1A.347
DO 14 BAND=1, NBANDS SWMAST1A.348
Cfpp$ Select(CONCUR) SWMAST1A.349
DO 14 J=1, L2 SWMAST1A.350
MODSA(J,BAND,DIRDIF) = TSA(J,BAND,DIRDIF) SWMAST1A.351
14 CONTINUE SWMAST1A.352
ENDIF SWMAST1A.353
C SWMAST1A.354
CL ! Last bit of Section 1 sets up the magnification factor for the SWMAST1A.355
CL ! direct beam. SWMAST1A.356
C SWMAST1A.357
DO 15 J=1, L2 SWMAST1A.358
DIRFAC(J) = HBYAP1 / SQRT ( COSZ(J)**2 + HBYAX2 ) SWMAST1A.359
15 CONTINUE SWMAST1A.360
C SWMAST1A.361
CL ! Section 2 SWMAST1A.362
CL ~~~~~~~~~ SWMAST1A.363
CL ! Calculate the flux at the top of the atmosphere taking account SWMAST1A.364
CL ! of Rayleigh scattering, and initialize parts of FLUX and PATH. SWMAST1A.365
C SWMAST1A.366
C ! Rayleigh scattering is represented by simply reflecting RAYSCA SWMAST1A.367
C ! of the incoming sunlight (in the shortest wavelength band) SWMAST1A.368
C ! before any interaction with the atmosphere. This is done by SWMAST1A.369
C ! subtracting RAYSCA from FSCIEB(1) before inserting the value SWMAST1A.370
C ! in the code, and by the following code for the top of the SWMAST1A.371
C ! model, where FSCIEB is not automatically picked up via SWTRAN. SWMAST1A.372
C ! SWMAST1A.373
C ! Obviously, if this is to be changed, consistency must be SWMAST1A.374
C maintained. SWMAST1A.375
DO 21 J=1, L2 SWMAST1A.376
FLUX(J,0) = ONELRS SWMAST1A.377
21 CONTINUE SWMAST1A.378
C SWMAST1A.379
IF ( CSOSON ) THEN SWMAST1A.380
DO J=1, L2 SWMAST1A.381
CSOSDI(J) = RAYSCA SWMAST1A.382
ENDDO SWMAST1A.383
ENDIF SWMAST1A.384
IF ( NSS1ON ) THEN SWMAST1A.385
DO J=1, L2 SWMAST1A.386
NSSB1(J) = 0. SWMAST1A.387
ENDDO SWMAST1A.388
ENDIF SWMAST1A.389
C SWMAST1A.390
DO 23 LEVEL=1, NLEVS SWMAST1A.391
Cfpp$ Select(CONCUR) SWMAST1A.392
DO 23 J=1, L2 SWMAST1A.393
FLUX(J,LEVEL) = 0. SWMAST1A.394
23 CONTINUE SWMAST1A.395
DO 24 GAS=1, NGASES SWMAST1A.396
Cfpp$ Select(CONCUR) SWMAST1A.397
DO 24 J=1, L2 SWMAST1A.398
PATH(J,GAS,DIRECT) = DIRFAC(J) * DPATH(J,GAS,1) SWMAST1A.399
24 CONTINUE SWMAST1A.400
C SWMAST1A.401
CL ! Section 3 SWMAST1A.402
CL ~~~~~~~~~ SWMAST1A.403
CL ! For the remaining layers above the levels where cloud may occur SWMAST1A.404
CL ! calculations are very simple - just loop down accumulating the SWMAST1A.405
CL ! gaseous pathlengths for the direct beam, calculating gaseous SWMAST1A.406
CL ! transmissivities from them and adding these in without having SWMAST1A.407
CL ! to use grey factors. SWMAST1A.408
C SWMAST1A.409
DO 3 LEVEL=2, LSTCLR SWMAST1A.410
Cfpp$ Expand SWMAST1A.411
CALL SWTRAN (PATH, TTEC, TRTAB, TRTAB(1,1,1,2), SWMAST1A.412
& L2, GSS2F402.9
& GTRANS) SWMAST1A.416
DO 32 BAND=1, NBANDS SWMAST1A.417
Cfpp$ Select(CONCUR) SWMAST1A.418
DO 32 J=1, L2 SWMAST1A.419
FLUX(J,LEVEL-1) = FLUX(J,LEVEL-1) + GTRANS(J,BAND) SWMAST1A.420
32 CONTINUE SWMAST1A.421
DO 34 GAS=1, NGASES SWMAST1A.422
Cfpp$ Select(CONCUR) SWMAST1A.423
DO 34 J=1, L2 SWMAST1A.424
PATH(J,GAS,DIRECT) = SWMAST1A.425
& PATH(J,GAS,DIRECT) + DIRFAC(J) * DPATH(J,GAS,LEVEL) SWMAST1A.426
34 CONTINUE SWMAST1A.427
3 CONTINUE SWMAST1A.428
C SWMAST1A.429
CL ! And, before starting the loop over cloudy layers, the code must SWMAST1A.430
CL ! initialize the grey factors for the direct beam and the light SWMAST1A.431
CL ! in the convective cloud. SWMAST1A.432
C SWMAST1A.433
DO 36 BAND=1, NBANDS SWMAST1A.434
Cfpp$ Select(CONCUR) SWMAST1A.435
DO 36 J=1, L2 SWMAST1A.436
GREY(J,BAND,DIRECT) = 1. SWMAST1A.437
36 CONTINUE SWMAST1A.438
C SWMAST1A.439
DO 38 BEAM=1, NCLDS SWMAST1A.440
DO 38 BAND=1, NBANDS SWMAST1A.441
Cfpp$ Select(CONCUR) SWMAST1A.442
DO 38 J=1, L2 SWMAST1A.443
GREY(J,BAND,NLEVS+BEAM) = 0. SWMAST1A.444
38 CONTINUE SWMAST1A.445
C SWMAST1A.446
CL ! Section 4 SWMAST1A.447
CL ~~~~~~~~~ SWMAST1A.448
CL ! Start the loop over cloudy levels, which has to be long and SWMAST1A.449
CL ! complex to allow for all the permitted interactions, and so is SWMAST1A.450
CL ! split into three sections. Section 4 calculates the flux terms SWMAST1A.451
CL ! for downward light at the top of layer LEVEL. SWMAST1A.452
C SWMAST1A.453
C SWMAST1A.454
DO 4 LEVEL=FSTCLD, NLEVS SWMAST1A.455
C ! Inside the loop over the levels for which we are finding the SWMAST1A.456
C ! flux, loop over the "beams" impinging on the level from above SWMAST1A.457
C ! - i.e. the categories of light whose histories are different SWMAST1A.458
C ! enough for us to keep separate pathlengths. SWMAST1A.459
DIRDIF = 1 SWMAST1A.460
DO 40 BEAM=LSTCLR, LEVEL-1 SWMAST1A.461
Cfpp$ Expand SWMAST1A.462
CALL SWTRAN (PATH(1,1,BEAM), TTEC, TRTAB, TRTAB(1,1,1,2), SWMAST1A.463
& L2, GSS2F402.10
& GTRANS) SWMAST1A.467
C ! For each beam and band, add in its gaseous transmissivity SWMAST1A.468
C ! multiplied by the right grey factor. Note that the grey SWMAST1A.469
C ! factors are defined for the total amount of light impinging SWMAST1A.470
C ! on the layer boundary from above, so that some manipulation SWMAST1A.471
C ! is needed to get GREYNT from the GREYs. SWMAST1A.472
C SWMAST1A.473
DO 41 BAND=1, NBANDS SWMAST1A.474
Cfpp$ Select(CONCUR) SWMAST1A.475
DO 41 J=1, L2 SWMAST1A.476
GREYNT = (1.-REF(J,BAND,LEVEL,DIRDIF)) * GREY(J,BAND,BEAM) SWMAST1A.477
C ! The light made diffuse by a cloud in layer BEAM in general SWMAST1A.478
C ! is partly accounted in GREY(,,BEAM) and partly in SWMAST1A.479
C ! GREY(,,BEAM+NCLDS), according as it is or is not inside a SWMAST1A.480
C ! convective cloud (and so not reflectable) at this layer. SWMAST1A.481
IF ( BEAM .NE. DIRECT ) SWMAST1A.482
& GREYNT = GREYNT + GREY(J,BAND,BEAM+NCLDS) SWMAST1A.483
C ! If the beam concerned is from the level containing the SWMAST1A.484
C ! convective cloud top, the light made diffuse by the SWMAST1A.485
C ! convective cloud is also added in. SWMAST1A.486
IF ( BEAM .EQ. CCT(J) ) SWMAST1A.487
& GREYNT = GREYNT + GREY(J,BAND,CONCLD) SWMAST1A.488
FLUX(J,LEVEL-1) = FLUX(J,LEVEL-1) + GTRANS(J,BAND) * GREYNT SWMAST1A.489
41 CONTINUE SWMAST1A.490
C SWMAST1A.491
CL ! Section 5 SWMAST1A.492
CL ~~~~~~~~~ SWMAST1A.493
CL ! This section calculates the flux due to reflection from the SWMAST1A.494
CL ! clouds in layer LEVEL through higher layers up to space. SWMAST1A.495
CL ! Recall that this light is assumed to pass to space without SWMAST1A.496
CL ! interaction with clouds, only gaseous absorption occurring. SWMAST1A.497
C SWMAST1A.498
CL ! First, set up RFGREY, the grey factor for the current beam: SWMAST1A.499
DO 53 BAND=1, NBANDS SWMAST1A.500
Cfpp$ Select(CONCUR) SWMAST1A.501
DO 53 J=1, L2 SWMAST1A.502
RFGREY(J,BAND) = REF(J,BAND,LEVEL,DIRDIF) * GREY(J,BAND,BEAM) SWMAST1A.503
53 CONTINUE SWMAST1A.504
CL ! and initialize RFPATH, its pathlength SWMAST1A.505
DO 55 GAS=1, NGASES SWMAST1A.506
Cfpp$ Select(CONCUR) SWMAST1A.507
DO 55 J=1, L2 SWMAST1A.508
RFPATH(J,GAS) = SWMAST1A.509
& PATH(J,GAS,BEAM) + DIFFAC * DPATH(J,GAS,LEVEL-1) SWMAST1A.510
55 CONTINUE SWMAST1A.511
CL ! and then loop up to the top of the atmosphere, putting in SWMAST1A.512
CL ! each upward flux term with no further calculation of grey SWMAST1A.513
CL ! terms, just finding transmissivities: SWMAST1A.514
DO 50 LEVEL2=LEVEL-2, 0, -1 SWMAST1A.515
Cfpp$ Expand SWMAST1A.516
CALL SWTRAN (RFPATH, TTEC, TRTAB, TRTAB(1,1,1,2), SWMAST1A.517
& L2, GSS2F402.11
& GTRANS) SWMAST1A.521
DO 57 BAND=1, NBANDS SWMAST1A.522
Cfpp$ Select(CONCUR) SWMAST1A.523
DO 57 J=1, L2 SWMAST1A.524
FLUX(J,LEVEL2) = FLUX(J,LEVEL2) - SWMAST1A.525
& RFGREY(J,BAND) * GTRANS(J,BAND) SWMAST1A.526
57 CONTINUE SWMAST1A.527
CL ! and incrementing RFPATH as each layer is crossed: SWMAST1A.528
IF (LEVEL2.NE.0) THEN SWMAST1A.529
DO 59 GAS=1, NGASES SWMAST1A.530
Cfpp$ Select(CONCUR) SWMAST1A.531
DO 59 J=1, L2 SWMAST1A.532
RFPATH(J,GAS) = SWMAST1A.533
& RFPATH(J,GAS) + DIFFAC * DPATH(J,GAS,LEVEL2) SWMAST1A.534
59 CONTINUE SWMAST1A.535
ENDIF SWMAST1A.536
50 CONTINUE SWMAST1A.537
DIRDIF=2 SWMAST1A.538
C SWMAST1A.539
40 CONTINUE ! End of the loop over BEAM SWMAST1A.540
C SWMAST1A.541
C SWMAST1A.542
CL ! Section 6 SWMAST1A.543
CL ~~~~~~~~~ SWMAST1A.544
CL ! Sections 4 and 5 dealt with transmission to and reflection from SWMAST1A.545
CL ! layer LEVEL: Section 6 prepares to deal with transmission SWMAST1A.546
CL ! through it by finding the effects of the cloud(s) whose tops SWMAST1A.547
CL ! are in it on the grey terms for the next layer boundary, and SWMAST1A.548
CL ! setting up the pathlengths to be used at the next layer SWMAST1A.549
CL boundary. SWMAST1A.550
CL SWMAST1A.551
CL ! The code is a little involved, but the physics being SWMAST1A.552
CL ! implemented is straightforward enough. SWMAST1A.553
CL ! Without convective cloud, all that would happen would be that SWMAST1A.554
CL ! direct light would be transmitted through the cloud-free area SWMAST1A.555
CL ! as direct light and through the cloud as diffuse light, and SWMAST1A.556
CL ! both direct and diffuse light would be attenuated in the SWMAST1A.557
CL ! cloudy area according to the appropriate transmissivity. SWMAST1A.558
CL ! At convective cloud top both clouds' fractional cover and SWMAST1A.559
CL ! transmissivities must be considered, and the amount of light SWMAST1A.560
CL ! going into the convective cloud acounted for. The latter SWMAST1A.561
CL ! will no longer be affected by clouds till it comes out of the SWMAST1A.562
CL ! convective cloud's base, when it can be combined with the SWMAST1A.563
CL ! rest of the diffuse light. The convective cloud need not be SWMAST1A.564
CL ! explicitly considered to calculate the change in the other SWMAST1A.565
CL ! grey factors "beside" it (i.e. when considering layer SWMAST1A.566
CL ! boundaries which it crosses), as the layer cloud fractions SWMAST1A.567
CL ! are there the fractions in the convective-cloud-free area. SWMAST1A.568
C SWMAST1A.569
C ! Rather than a line-by-line explanation of the code in this SWMAST1A.570
C ! loop, the physical explanation above and the definitions of SWMAST1A.571
C ! each quantity seem most useful. SWMAST1A.572
C ! DIFFTR is an effective grey transmissivity of the layer to SWMAST1A.573
C ! diffuse light: the fraction of that diffuse light to impinge SWMAST1A.574
C ! on the layer not in convective cloud which is transmitted not SWMAST1A.575
C ! in convective cloud, ignoring gaseous absorption. SWMAST1A.576
C SWMAST1A.577
DO 6 BAND=1, NBANDS SWMAST1A.578
Cfpp$ Select(CONCUR) SWMAST1A.579
DO 61 J=1, L2 SWMAST1A.580
GREY(J,BAND,LEVEL) = SWMAST1A.581
& LCA(J,LEVEL) * CTRANS(J,BAND,LEVEL,1) * GREY(J,BAND,DIRECT) SWMAST1A.582
DIFFTR(J) = 1. - LCA(J,LEVEL) * ( 1. - CTRANS(J,BAND,LEVEL,2) ) SWMAST1A.583
IF ( CCT(J) .EQ. LEVEL ) THEN SWMAST1A.584
GREY(J,BAND,CONCLD) = SWMAST1A.585
& CCA(J) * CCTRANS(J,BAND,1) * GREY(J,BAND,DIRECT) SWMAST1A.586
GREY(J,BAND,LEVEL) = GREY(J,BAND,LEVEL) * ( 1. - CCA(J) ) SWMAST1A.587
DIFFTR(J) = DIFFTR(J) * ( 1. - CCA(J) ) SWMAST1A.588
GREY(J,BAND,DIRECT) = GREY(J,BAND,DIRECT) * ( 1. - CCA(J) ) SWMAST1A.589
ENDIF SWMAST1A.590
61 CONTINUE SWMAST1A.591
C SWMAST1A.592
DO 64 BEAM=FSTCLD, LEVEL-1 SWMAST1A.593
Cfpp$ Select(CONCUR) SWMAST1A.594
DO 64 J=1, L2 SWMAST1A.595
IF ( CCT(J) .EQ. LEVEL ) GREY(J,BAND,BEAM+NCLDS) = SWMAST1A.596
& GREY(J,BAND,BEAM) * CCA(J) * CCTRANS(J,BAND,2) SWMAST1A.597
GREY(J,BAND,BEAM) = GREY(J,BAND,BEAM) * DIFFTR (J) SWMAST1A.598
IF ( CCB(J) .EQ. LEVEL ) THEN SWMAST1A.599
GREY(J,BAND,BEAM) = SWMAST1A.600
& GREY(J,BAND,BEAM) + GREY(J,BAND,BEAM+NCLDS) SWMAST1A.601
GREY(J,BAND,BEAM+NCLDS) = 0. SWMAST1A.602
ENDIF SWMAST1A.603
64 CONTINUE SWMAST1A.604
C SWMAST1A.605
Cfpp$ Select(CONCUR) SWMAST1A.606
DO 6 J=1, L2 SWMAST1A.607
GREY(J,BAND,DIRECT) = GREY(J,BAND,DIRECT)*( 1. - LCA(J,LEVEL) ) SWMAST1A.608
IF ( CCB(J) .EQ. LEVEL ) THEN SWMAST1A.609
GREY(J,BAND,CCT(J)) = SWMAST1A.610
& GREY(J,BAND,CCT(J)) + GREY(J,BAND,CONCLD) SWMAST1A.611
GREY(J,BAND,CONCLD) = 0. SWMAST1A.612
ENDIF SWMAST1A.613
6 CONTINUE SWMAST1A.614
C ! Set up pathlengths for the bottom of the layer LEVEL. SWMAST1A.615
DO 66 GAS=1, NGASES SWMAST1A.616
Cfpp$ Select(CONCUR) SWMAST1A.617
DO 66 J=1, L2 SWMAST1A.618
C ! The newly created beam's pathlengths are as for the direct SWMAST1A.619
C ! beam up to layer LEVEL and diffuse through it: SWMAST1A.620
PATH(J,GAS,LEVEL) = SWMAST1A.621
& PATH(J,GAS,DIRECT) + DIFFAC * DPATH(J,GAS,LEVEL) SWMAST1A.622
C ! while the direct beam again adds on the layer pathlengths SWMAST1A.623
C ! multiplied by the direct beam magnification factor: SWMAST1A.624
PATH(J,GAS,DIRECT) = SWMAST1A.625
& PATH(J,GAS,DIRECT) + DIRFAC(J) * DPATH(J,GAS,LEVEL) SWMAST1A.626
66 CONTINUE SWMAST1A.627
C ! and all the pre-existing diffuse beams add on the layer SWMAST1A.628
C ! pathlengths multiplied by the diffusivity factor: SWMAST1A.629
DO 68 BEAM=FSTCLD, LEVEL-1 SWMAST1A.630
DO 68 GAS=1, NGASES SWMAST1A.631
Cfpp$ Select(CONCUR) SWMAST1A.632
DO 68 J=1, L2 SWMAST1A.633
PATH(J,GAS,BEAM) = SWMAST1A.634
& PATH(J,GAS,BEAM) + DIFFAC * DPATH(J,GAS,LEVEL) SWMAST1A.635
68 CONTINUE SWMAST1A.636
C SWMAST1A.637
4 CONTINUE ! End of the outer loop over LEVEL SWMAST1A.638
C SWMAST1A.639
CL ! Section 8 SWMAST1A.640
CL ~~~~~~~~~ SWMAST1A.641
CL ! This section calculates the surface flux and the effects of the SWMAST1A.642
CL ! light reflected from the surface. It is thus similar to SWMAST1A.643
CL ! Sections 4 and 5, but simpler in that the surface does not SWMAST1A.644
CL ! have fractional cover, transmissivity or a beam crossing it SWMAST1A.645
CL ! inside convective cloud. However this physical simplicity SWMAST1A.646
CL ! is partly offset by the fact that extra outputs are SWMAST1A.647
CL ! calculated - DSFLUX and possibly surface diagnostics. SWMAST1A.648
C SWMAST1A.649
DO J=1, L2 SWMAST1A.650
DSFLUX(J) = 0. SWMAST1A.651
ENDDO SWMAST1A.652
IF ( TDSSON ) THEN SWMAST1A.653
DO J=1, L2 SWMAST1A.654
TDSS(J) = 0. SWMAST1A.655
ENDDO SWMAST1A.656
ENDIF SWMAST1A.657
C SWMAST1A.658
C ! First time round, use direct-light albedos: SWMAST1A.659
DIRDIF=1 SWMAST1A.660
C ! The "DO 8" loop is similar to the "DO 40" loop. SWMAST1A.661
DO 8 BEAM=DIRECT, NLEVS SWMAST1A.662
Cfpp$ Expand SWMAST1A.663
CALL SWTRAN (PATH(1,1,BEAM), TTEC, TRTAB, TRTAB(1,1,1,2), SWMAST1A.664
& L2, GSS2F402.12
& GTRANS) SWMAST1A.668
C ! The "DO 81" loops are similar to the "DO 41" loops, but rather SWMAST1A.669
C ! simpler, as there cannot be any convective cloud crossing SWMAST1A.670
C ! this layer boundary. SWMAST1A.671
DO 81 BAND=1, NBANDS SWMAST1A.672
Cfpp$ Select(CONCUR) SWMAST1A.673
DO 81 J=1, L2 SWMAST1A.674
SIF = GTRANS(J,BAND) * GREY(J,BAND,BEAM) SWMAST1A.675
FLUX(J,NLEVS) = FLUX(J,NLEVS) + SIF * (1.-MODSA(J,BAND,DIRDIF)) SWMAST1A.676
DSFLUX(J) = DSFLUX(J) + SIF * SWMAST1A.677
& ( 1. - DTSA(J,BAND,DIRDIF) + SWMAST1A.678
& ( TSA(J,BAND,DIRDIF) - MODSA(J,BAND,DIRDIF) ) * SWMAST1A.679
& ( 1. - DTSA(J,BAND,2) ) / ( 1. - TSA(J,BAND,2) ) ) SWMAST1A.680
81 CONTINUE SWMAST1A.681
IF ( TDSSON ) THEN SWMAST1A.682
IF ( BEAM .EQ. DIRECT ) THEN SWMAST1A.683
DO 811 BAND=1, NBANDS SWMAST1A.684
DO J=1, L2 SWMAST1A.685
TDSS(J) = TDSS(J) + GTRANS(J,BAND) * GREY(J,BAND,BEAM) * SWMAST1A.686
& ( 1. + (TSA(J,BAND,1)-MODSA(J,BAND,1)) / (1.-TSA(J,BAND,2)) ) SWMAST1A.687
ENDDO SWMAST1A.688
811 CONTINUE SWMAST1A.689
ELSE ! Diffuse beam SWMAST1A.690
DO 818 BAND=1, NBANDS SWMAST1A.691
DO J=1, L2 SWMAST1A.692
TDSS(J) = TDSS(J) + GTRANS(J,BAND) * GREY(J,BAND,BEAM) * SWMAST1A.693
& ( 1.-MODSA(J,BAND,DIRDIF) ) / ( 1.-TSA(J,BAND,DIRDIF) ) SWMAST1A.694
ENDDO SWMAST1A.695
818 CONTINUE SWMAST1A.696
ENDIF SWMAST1A.697
ENDIF SWMAST1A.698
IF ( NSS1ON ) THEN SWMAST1A.699
Cfpp$ Select(CONCUR) SWMAST1A.700
DO J=1, L2 SWMAST1A.701
NSSB1(J) = NSSB1(J) + SWMAST1A.702
& GTRANS(J,1) * GREY(J,1,BEAM) * SWMAST1A.703
& ( 1. - DTSA(J,1,DIRDIF) + SWMAST1A.704
& ( TSA(J,1,DIRDIF) - MODSA(J,1,DIRDIF) ) * SWMAST1A.705
& ( 1. - DTSA(J,1,2) ) / ( 1. - TSA(J,1,2) ) ) SWMAST1A.706
ENDDO SWMAST1A.707
ENDIF SWMAST1A.708
IF ( CSSSDO .AND. BEAM .EQ. DIRECT ) THEN SWMAST1A.709
DO J=1, L2 SWMAST1A.710
CSSSD(J) = GTRANS(J,1) SWMAST1A.711
ENDDO SWMAST1A.712
DO 812 BAND=2, NBANDS SWMAST1A.713
Cfpp$ Select(CONCUR) SWMAST1A.714
DO J=1, L2 SWMAST1A.715
CSSSD(J) = CSSSD(J) + GTRANS(J,BAND) SWMAST1A.716
ENDDO SWMAST1A.717
812 CONTINUE SWMAST1A.718
ENDIF SWMAST1A.719
IF ( CSSSUO .AND. BEAM .EQ. DIRECT ) THEN SWMAST1A.720
DO J=1, L2 SWMAST1A.721
CSSSU(J) = GTRANS(J,1) * TSA(J,1,1) SWMAST1A.722
ENDDO SWMAST1A.723
DO 813 BAND=2, NBANDS SWMAST1A.724
Cfpp$ Select(CONCUR) SWMAST1A.725
DO J=1, L2 SWMAST1A.726
CSSSU(J) = CSSSU(J) + GTRANS(J,BAND) * TSA(J,BAND,1) SWMAST1A.727
ENDDO SWMAST1A.728
813 CONTINUE SWMAST1A.729
ENDIF SWMAST1A.730
CL ! As in "DO 53", set up RFGREY, grey factor for the current beam SWMAST1A.731
DO 83 BAND=1, NBANDS SWMAST1A.732
Cfpp$ Select(CONCUR) SWMAST1A.733
DO 83 J=1, L2 SWMAST1A.734
RFGREY(J,BAND) = MODSA(J,BAND,DIRDIF) * GREY(J,BAND,BEAM) SWMAST1A.735
83 CONTINUE SWMAST1A.736
CL ! and, as in "DO 55", initialize RFPATH, its pathlength SWMAST1A.737
DO 85 GAS=1, NGASES SWMAST1A.738
Cfpp$ Select(CONCUR) SWMAST1A.739
DO 85 J=1, L2 SWMAST1A.740
RFPATH(J,GAS) = SWMAST1A.741
& PATH(J,GAS,BEAM) + DIFFAC * DPATH(J,GAS,NLEVS) SWMAST1A.742
85 CONTINUE SWMAST1A.743
CL ! and then, as in "DO 50" & "DO 57", loop up to the top of the SWMAST1A.744
CL ! atmosphere, putting in each upward flux term with no further SWMAST1A.745
CL ! calculation of grey terms, just finding transmissivities: SWMAST1A.746
DO 80 LEVEL2=NLEVS-1, 0, -1 SWMAST1A.747
Cfpp$ Expand SWMAST1A.748
CALL SWTRAN (RFPATH, TTEC, TRTAB, TRTAB(1,1,1,2), SWMAST1A.749
& L2, GSS2F402.13
& GTRANS) SWMAST1A.753
DO 87 BAND=1, NBANDS SWMAST1A.754
Cfpp$ Select(CONCUR) SWMAST1A.755
DO 87 J=1, L2 SWMAST1A.756
FLUX(J,LEVEL2) = FLUX(J,LEVEL2) - SWMAST1A.757
& RFGREY(J,BAND) * GTRANS(J,BAND) SWMAST1A.758
87 CONTINUE SWMAST1A.759
C ! and, as in "DO 59", incrementing RFPATH for each layer crossed SWMAST1A.760
IF ( LEVEL2 .NE. 0 ) THEN SWMAST1A.761
DO 89 GAS=1, NGASES SWMAST1A.762
Cfpp$ Select(CONCUR) SWMAST1A.763
DO 89 J=1, L2 SWMAST1A.764
RFPATH(J,GAS) = SWMAST1A.765
& RFPATH(J,GAS) + DIFFAC * DPATH(J,GAS,LEVEL2) SWMAST1A.766
89 CONTINUE SWMAST1A.767
ENDIF SWMAST1A.768
80 CONTINUE SWMAST1A.769
IF ( CSOSON .AND. BEAM .EQ. DIRECT ) THEN SWMAST1A.770
DO 92 BAND=1, NBANDS SWMAST1A.771
DO 93 J=1, L2 SWMAST1A.772
CSOSDI(J) = CSOSDI(J) + GTRANS(J,BAND) * TSA(J,BAND,1) SWMAST1A.773
93 CONTINUE SWMAST1A.774
92 CONTINUE SWMAST1A.775
ENDIF SWMAST1A.776
C ! After the first time round, use diffuse-light albedos: SWMAST1A.777
DIRDIF = 2 SWMAST1A.778
8 CONTINUE SWMAST1A.779
C SWMAST1A.780
RETURN SWMAST1A.781
END SWMAST1A.782
*ENDIF SWMAST1A.783