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