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