*IF DEF,A02_1A LWMAST1A.2
C ******************************COPYRIGHT****************************** GTS2F400.5563
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.5564
C GTS2F400.5565
C Use, duplication or disclosure of this code is subject to the GTS2F400.5566
C restrictions as set forth in the contract. GTS2F400.5567
C GTS2F400.5568
C Meteorological Office GTS2F400.5569
C London Road GTS2F400.5570
C BRACKNELL GTS2F400.5571
C Berkshire UK GTS2F400.5572
C RG12 2SZ GTS2F400.5573
C GTS2F400.5574
C If no contract has been raised with this copy of the code, the use, GTS2F400.5575
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.5576
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.5577
C Modelling at the above address. GTS2F400.5578
C ******************************COPYRIGHT****************************** GTS2F400.5579
C GTS2F400.5580
CLL Routine LWMAST ----------------------------------------------- LWMAST1A.3
CLL Before LWMAST is CALLed, LWLKIN (in deck LWTRAN) must be CALLed to LWMAST1A.4
CLL initialize LUT. LWMAST1A.5
*ENDIF A02_1A LWMAST1A.6
*IF DEF,A02_1B LWMAST1A.7
CLL (Comment here referred to the former deckname - deleted MJH) LWMAST1A.8
*ENDIF A02_1B LWMAST1A.9
*IF DEF,A02_1A,OR,DEF,A02_1B LWMAST1A.10
CLL Purpose: LWMAST1A.11
CLL It calculates net longwave fluxes (and optionally flux diagnostics) LWMAST1A.12
CLL from the Planck flux differences found by LWPLAN, transmissivities LWMAST1A.13
CLL found by LWTRAN, and cloud arrays filled by LWCLD. LWMAST1A.14
CLL If UPDATE *DEF CRAY is off, the code is standard FORTRAN 77 except LWMAST1A.15
CLL for having ! comments (it then sets the "vector length" to 1) but LWMAST1A.16
CLL otherwise it includes automatic arrays also. LWMAST1A.17
CLL LWMAST1A.18
CLL Author: William Ingram LWMAST1A.19
CLL LWMAST1A.20
CLL Model Modification history from model version 3.0: LWMAST1A.21
CLL version Date LWMAST1A.22
CLL 4.2 Sept.96 T3E migration: *DEF CRAY removed; GSS1F402.42
CLL *DEF T3E used for T3E library functions; GSS1F402.43
CLL dynamic allocation no longer *DEF controlled; GSS1F402.44
CLL cray HF functions replaced by T3E lib functions. GSS1F402.45
CLL S.J.Swarbrick GSS1F402.46
! 4.4 10/4/97 Pass logical through to LWCLD to indicate the AYY1F404.326
! prognostic cloud ice should be used. AC Bushell AYY1F404.327
CLL LWMAST1A.23
CLL It conforms with standard A of version 3 (07/9/90) of UMDP 4, and LWMAST1A.24
CLL contains no 8X-deprecated features. LWMAST1A.25
CLL LWMAST1A.26
CLL Logical components covered: P232 , D23... LWMAST1A.27
CLL It is the top-level plug-compatible routine in component P232 LWMAST1A.28
CLL (longwave radiation) LWMAST1A.29
CLL LWMAST1A.30
CLL It also performs some of LWMAST1A.31
CLL the functions of D23 (radiation diagnostics). LWMAST1A.32
CLL LWMAST1A.33
CLL System task P23 (radiation). LWMAST1A.34
CLL LWMAST1A.35
CLL Offline documentation is in UMDP 23. LWMAST1A.36
CLLEND --------------------------------------------------------- LWMAST1A.37
C*L LWMAST1A.38
SUBROUTINE LWMAST (H2O, CO2, O3, TAC, PEXNER, TSTAR, PSTAR, AB, 2,12LWMAST1A.39
& BB, AC, BC, AICE, LCA, LCCWC1, LCCWC2, CCA, CCCWP, CCB, CCT, LWMAST1A.40
& LUT, LWMAST1A.41
& CSOLRD, CSOLON, SFDN, SFDNON, CSSFDN, CSSDON, LWMAST1A.42
& L_CLOUD_WATER_PARTITION, AYY1F404.328
& L2, NLEVS, NCLDS, GSS1F402.47
& NWET, NOZONE, L1, SEAFX, FLUX) LWMAST1A.46
C* LWMAST1A.47
EXTERNAL LWCLD, LWPLAN, LWPTSC, LWTRAN LWMAST1A.48
*CALL LWNBANDS 
LWMAST1A.49
*CALL LWNGASES LWMAST1A.50
*CALL LWNTRANS LWMAST1A.51
*CALL LWNLKUPS LWMAST1A.52
C ! Array dimensions must be constants in FORTRAN: LWMAST1A.54
C*L LWMAST1A.59
INTEGER!, INTENT(IN) :: LWMAST1A.60
& L2, ! Number of points to be treated LWMAST1A.62
& NLEVS, ! Number of levels LWMAST1A.63
& NCLDS, ! Number of possibly cloudy levels LWMAST1A.64
& NWET, ! Number of levels with moisture LWMAST1A.66
& NOZONE, ! Number of levels with ozone LWMAST1A.67
& L1 ! Full field dimension LWMAST1A.68
REAL!, INTENT(IN) :: LWMAST1A.69
& H2O(L1,NWET), CO2, ! Mixing ratios of the three LWMAST1A.70
& O3(L1,NOZONE), ! absorbing gases LWMAST1A.71
& TAC(L1,NLEVS), ! Temperature at layer centres LWMAST1A.72
& PEXNER(L1,NLEVS+1), ! Exner function @ layer boundaries LWMAST1A.73
& TSTAR(L1), PSTAR(L1), ! Surface temperature & pressure LWMAST1A.74
& AC(NLEVS), BC(NLEVS), ! A & B for layer centres and LWMAST1A.75
& AB(NLEVS+1), BB(NLEVS+1), ! boundaries LWMAST1A.76
& LUT(IT,NTRANS,NGASES,2), ! Look-up tables for LWTRAN LWMAST1A.77
& AICE(L1), ! Sea-ice fraction LWMAST1A.78
& LCCWC1(L1,1/(NCLDS+1)+NCLDS), LCCWC2(L1,1/(NCLDS+1)+NCLDS), LWMAST1A.79
C ! Layer cloud condensed water contents (specific contents, mass LWMAST1A.80
C ! per unit mass). Only the sum of these two fields is used. LWMAST1A.81
& LCA(L1,1/(NCLDS+1)+NCLDS),! Layer cloud fractional cover LWMAST1A.82
& CCCWP(L1), ! Convective cloud fractional cover LWMAST1A.83
& CCA(L1) ! and condensed water path LWMAST1A.84
C ! (LWCLD describes precisely which these cloud quantities are.) LWMAST1A.85
INTEGER!, INTENT(IN) :: LWMAST1A.86
& CCB(L1), CCT(L1) ! Convective cloud base and top LWMAST1A.87
LOGICAL!, INTENT(IN) LWMAST1A.88
& CSOLON ! Is CSOLRD wanted ? LWMAST1A.89
& , SFDNON ! And is SFDN ? LWMAST1A.90
& , CSSDON ! & is CSSFDN ? LWMAST1A.91
C ! (If so, SFDNON must be set too) LWMAST1A.92
& ,L_CLOUD_WATER_PARTITION ! Is cloud ice prognostic? AYY1F404.329
REAL!, INTENT(OUT) :: LWMAST1A.93
& FLUX(L1,NLEVS+1), ! Net longwave flux (+ downwards) LWMAST1A.94
& CSOLRD(L1), ! diagnosed clear-sky OLR LWMAST1A.95
& SFDN(L1), ! Diagnosed downward surface flux LWMAST1A.96
& CSSFDN(L1), ! and its clear-sky equivalent LWMAST1A.97
& SEAFX(L1) ! Term calculated by LWPLAN & used LWMAST1A.98
! by LWRAD to derive open-sea-only flux at sea-ice points. LWMAST1A.99
C* LWMAST1A.100
CL ! After zeroing FLUX and SEAFX, LWMAST1A.101
CL ! LWMAST calls LWPLAN, LWPTSC & LWCLD to set up arrays. LWMAST1A.102
*IF DEF,RANDOVER LWMAST1A.103
CL ! and initializes an array DNSRCE ("DO 10" loop). LWMAST1A.104
*ENDIF RANDOVER LWMAST1A.105
CL ! Then it adds in the half-layer terms for each layer to the LWMAST1A.106
CL ! fluxes at the boundaries of that layer ("DO 2" loop). LWMAST1A.107
CL ! Most of the code is inside the "DO 3" loop and calculates LWMAST1A.108
CL ! the contribution to the flux at every layer boundary from every LWMAST1A.109
CL ! other. That loop supplies the lower level being treated. LWMAST1A.110
CL ! Loops inside it ("DO 30" for layers that may contain cloud LWMAST1A.111
CL ! and "DO 38" for the others) supply the upper layer. LWMAST1A.112
REAL ! WORKSPACE LWMAST1A.113
& DB(L2,NLEVS,NBANDS,2), ! Differences of the black-body LWMAST1A.114
C ! flux across bottom and top halves of layers, LWMAST1A.115
C ! DB(,LEVEL,,1) between half-level LEVEL-1/2 & full-level LEVEL, LWMAST1A.116
C ! DB(,LEVEL,,2) between full-level LEVEL & half-level LEVEL+1/2. LWMAST1A.117
& TRANS(L2,NTRANS), ! Transmissivities LWMAST1A.118
& DPATH(L2,NGASES,NLEVS), ! Scaled gas pathlengths for each LWMAST1A.119
& PATH(L2,NGASES), ! layer & current total path LWMAST1A.120
& ECA(L2,NCLDS+1/(NCLDS+1),NBANDS), LWMAST1A.121
C ! Effective clear-sky fraction: 1-ECA is cloud amount*emissivity LWMAST1A.122
*IF DEF,RANDOVER LWMAST1A.123
& ECTA(L2,NCLDS,NBANDS), LWMAST1A.124
& ECBA(L2,NCLDS,NBANDS), ! Effective amount of LWMAST1A.125
C ! cloud (amount*emissivity) having its top or bottom in each layer LWMAST1A.126
*ENDIF RANDOVER LWMAST1A.127
& EFFTRA, UPSRCE(L2,NBANDS), LWMAST1A.128
C ! EFFTRA is a temporary product of TRANS and a clear-sky term LWMAST1A.129
*IF DEF,RANDOVER LWMAST1A.130
& DNSRCE(L2,NBANDS,2:(NCLDS+2/(NCLDS+1))), LWMAST1A.131
C ! NCLDS+2/(NCLDS+1)=MAX(NCLDS,2) if NCLDS>=0 LWMAST1A.132
& CLRF(L2,NBANDS), CLDCLB LWMAST1A.133
C ! Because random overlap of clouds in different layers is assumed, LWMAST1A.134
C ! a dB source term for upward and downward flux at each layer LWMAST1A.135
C ! boundary, from so much cloud surface (top or base respectively) LWMAST1A.136
C ! and so much clear sky, can be pre-calculated. These are UPSRCE LWMAST1A.137
C ! and DNSRCE respectively. Then the contribution from one layer LWMAST1A.138
C ! to the flux at any other is given by the dB source term, the LWMAST1A.139
C ! gaseous transmissivity between the two layers, and the fraction LWMAST1A.140
C ! of the grid-box where the two layers' view of each other is not LWMAST1A.141
C ! blocked by intervening cloud, CLRF. CLDCLB is defined so that LWMAST1A.142
C ! (1-CLDCLB) is the effective cloud cover crossing a layer LWMAST1A.143
C ! boundary. LWMAST1A.144
*ELSE RANDOVER LWMAST1A.145
C ! UPSRCE is a source term for the contribution to the flux at the LWMAST1A.146
C ! upper layer boundary when this is above all possible clouds. LWMAST1A.147
& UPCLRF(L2,NBANDS), UPCLDF(L2,NBANDS), DNCLRF(L2,NBANDS), LWMAST1A.148
& DNCLDF, DNCLRO, F1CON, F2CON LWMAST1A.149
C ! We assume that clouds in different layers overlap maximally if LWMAST1A.150
C ! there is cloud in all the layers between, but randomly if there LWMAST1A.151
C ! is any clear layer between. Thus they can be grouped into LWMAST1A.152
C ! contiguous "blocks" separated by clear layers, and overlap is LWMAST1A.153
C ! maximal within a block but random between blocks. LWMAST1A.154
C ! UPCLRF & UPCLDF are the fractions of the lower layer boundary LWMAST1A.155
C ! which are visible from the highest intervening clear layer (if LWMAST1A.156
C ! any) or from the upper layer boundary (if not) and are LWMAST1A.157
C ! effectively clear or have a cloud top active respectively. LWMAST1A.158
C ! DNCLRF and DNCLDF are similar but the other way up (switch LWMAST1A.159
C ! "higher" and "lower" in the definition, and change "cloud top" LWMAST1A.160
C ! to "cloud base"). LWMAST1A.161
C ! DNCLRO is the previous layer's value of DNCLRF, or equivalently LWMAST1A.162
C ! the minimum clear fraction in the layers between the two layer LWMAST1A.163
C ! boundaries and in the same cloud block as the layer below the LWMAST1A.164
C ! upper layer boundary. LWMAST1A.165
C ! F1,2CON are the contributions to the flux at each level from the LWMAST1A.166
C ! other, before allowing for gaseous transmissivities. LWMAST1A.167
LOGICAL NOCLRB(L2) LWMAST1A.168
C ! NOCLRB is true if there is no clear layer between the two layer LWMAST1A.169
C ! boundaries. Then UPCLRF to DNCLDF directly give the fractions LWMAST1A.170
C ! of the grid-box where the upward and downward fluxes have a LWMAST1A.171
C ! clear and a cloudy contribution. If not extra terms are needed. LWMAST1A.172
*ENDIF RANDOVER LWMAST1A.173
*CALL LWFLSTBD LWMAST1A.174
*CALL LWKCONT LWMAST1A.175
INTEGER BAND, GAS, ! Loopers over band, absorbing LWMAST1A.176
& LEVEL, LEVEL2, J, ! gas, levels and points LWMAST1A.177
*IF -DEF,RANDOVER WI200893.1
& LEVELA, ! Level at which an array is WI200893.2
C ! accessed in a couple of loops where using the loop counter would WI200893.3
C ! give out-of-bound memory references, when the value will not WI200893.4
C ! actually be used. WI200893.5
*ENDIF -RANDOVER WI200893.6
& FSCLYR ! Start of the "DO 38" loop LWMAST1A.178
CL LWMAST1A.179
CL ! SECTION 1 LWMAST1A.180
CL LWMAST1A.181
CL ! 1.1 Zero output space LWMAST1A.182
CL LWMAST1A.183
DO 1 LEVEL=1, NLEVS+1 LWMAST1A.184
Cfpp$ Select(CONCUR) LWMAST1A.185
DO 1 J=1, L2 LWMAST1A.186
FLUX(J,LEVEL) = 0. LWMAST1A.187
1 CONTINUE LWMAST1A.188
CL LWMAST1A.189
CL ! 1.11 zero SEAFX LWMAST1A.190
CL LWMAST1A.191
DO 11 J=1, L2 LWMAST1A.192
SEAFX(J) = 0. LWMAST1A.193
11 CONTINUE LWMAST1A.194
CL LWMAST1A.195
CL ! 1.12 Zero CSOLRD: LWMAST1A.196
CL LWMAST1A.197
IF ( CSOLON ) THEN LWMAST1A.198
DO J=1, L2 LWMAST1A.199
CSOLRD(J) = 0. LWMAST1A.200
ENDDO LWMAST1A.201
ENDIF LWMAST1A.202
CL LWMAST1A.203
CL ! and SFDN: LWMAST1A.204
CL LWMAST1A.205
IF ( SFDNON ) THEN LWMAST1A.206
DO J=1, L2 LWMAST1A.207
SFDN(J) = 0. LWMAST1A.208
ENDDO LWMAST1A.209
ENDIF LWMAST1A.210
C LWMAST1A.211
C ! and CSSFDN: LWMAST1A.212
C LWMAST1A.213
IF ( CSSDON ) THEN LWMAST1A.214
DO J=1, L2 LWMAST1A.215
CSSFDN(J) = 0. LWMAST1A.216
ENDDO LWMAST1A.217
ENDIF LWMAST1A.218
CL LWMAST1A.219
CL ! 1.2 Set up dB arrays from temperature arrays LWMAST1A.220
CL LWMAST1A.221
Cfpp$ Expand LWMAST1A.222
CALL LWPLAN (TAC, PEXNER, PSTAR, AB, BB, TSTAR, AICE, LWMAST1A.223
& SFDN, SFDNON, LWMAST1A.224
& L2, NLEVS, L1, SEAFX, DB, DB(1,1,1,2)) LWMAST1A.225
C LWMAST1A.226
CL LWMAST1A.227
CL ! 1.3 Set up arrays of scaled pathlengths (Eqs 2.3.1 to 2.3.10) LWMAST1A.228
CL LWMAST1A.229
Cfpp$ Expand LWMAST1A.230
CALL LWPTSC (H2O, CO2, O3, PSTAR, AC, BC, AB, BB, TAC, LWMAST1A.231
& L2, GSS1F402.48
& NWET, NOZONE, NLEVS, L1, DPATH) LWMAST1A.235
CL LWMAST1A.236
CL 1.4 Set arrays of effective amount of clear sky, cloud base & top LWMAST1A.237
CL LWMAST1A.238
IF ( NCLDS .GT. 0 ) THEN LWMAST1A.239
Cfpp$ Expand LWMAST1A.240
CALL LWCLD (LCA, LCCWC1, LCCWC2, CCA, CCCWP, CCB, CCT, TAC, LWMAST1A.241
& PSTAR, AB, BB, L_CLOUD_WATER_PARTITION, L1, NLEVS, NCLDS, AYY1F404.330
& L2, GSS1F402.49
*IF DEF,RANDOVER LWMAST1A.246
& ECTA, ECBA, LWMAST1A.247
*ENDIF RANDOVER LWMAST1A.248
& ECA) LWMAST1A.249
ENDIF LWMAST1A.250
*IF DEF,RANDOVER LWMAST1A.251
CL LWMAST1A.252
CL ! and set DNSRCE LWMAST1A.253
CL LWMAST1A.254
DO 10 LEVEL=2, NCLDS LWMAST1A.255
DO 10 BAND=1, NBANDS LWMAST1A.256
Cfpp$ Select(CONCUR) LWMAST1A.257
DO 10 J=1, L2 LWMAST1A.258
C ! This division by CLDCLB, as well as the 2 later, would fail LWMAST1A.259
C ! if the inputs specified total cover by a black cloud more LWMAST1A.260
C ! than one layer thick - but not for the physically identical LWMAST1A.261
C ! case of total cover by black clouds in adjacent layers. LWMAST1A.262
CLDCLB = ECA(J,LEVEL,BAND) + ECBA(J,LEVEL,BAND) LWMAST1A.263
DNSRCE(J,BAND,LEVEL) = LWMAST1A.264
& ECA(J,LEVEL,BAND) * DB(J,LEVEL,BAND,1) / CLDCLB + LWMAST1A.265
& DB(J,LEVEL-1,BAND,2) LWMAST1A.266
10 CONTINUE LWMAST1A.267
*ENDIF RANDOVER LWMAST1A.268
CL LWMAST1A.269
CL ! SECTION 2 LWMAST1A.270
CL LWMAST1A.271
CL ! Add in the "half-layer" contributions. LWMAST1A.272
CL ! Transmissivities are calculated from pathlengths which are LWMAST1A.273
CL ! a quarter those for the full layers (Eq 2.1.9): LWMAST1A.274
CL LWMAST1A.275
DO 2 LEVEL=1, NLEVS LWMAST1A.276
DO 21 GAS=1, NGASES LWMAST1A.277
Cfpp$ Select(CONCUR) LWMAST1A.278
DO 21 J=1, L2 LWMAST1A.279
PATH(J,GAS) = .25 * DPATH(J,GAS,LEVEL) LWMAST1A.280
21 CONTINUE LWMAST1A.281
C LWMAST1A.282
CALL LWTRAN (PATH, LUT, LUT(1,1,1,2), FLSTBD, KCONT, LWMAST1A.283
& L2, GSS1F402.50
& TRANS) LWMAST1A.287
IF (LEVEL.LE.NCLDS) THEN LWMAST1A.288
C ! In levels low enough that cloud may occur, there is no LWMAST1A.289
C ! radiative flux in the part of the grid-box covered by the LWMAST1A.290
C ! equivalent black-body cloud. LWMAST1A.291
DO 22 BAND=1, NBANDS LWMAST1A.292
Cfpp$ Select(CONCUR) LWMAST1A.293
DO 22 J=1, L2 LWMAST1A.294
EFFTRA = TRANS(J,BAND) * ECA(J,LEVEL,BAND) LWMAST1A.295
FLUX(J,LEVEL) = FLUX(J,LEVEL) + EFFTRA * DB(J,LEVEL,BAND,1) LWMAST1A.296
FLUX(J,LEVEL+1) = FLUX(J,LEVEL+1) + LWMAST1A.297
& EFFTRA * DB(J,LEVEL,BAND,2) LWMAST1A.298
22 CONTINUE LWMAST1A.299
ELSE IF (LEVEL.LT.NLEVS) THEN LWMAST1A.300
C ! Further up, Eq 2.1.9 applies simply: LWMAST1A.301
DO 23 BAND=1, NBANDS LWMAST1A.302
Cfpp$ Select(CONCUR) LWMAST1A.303
DO 23 J=1, L2 LWMAST1A.304
FLUX(J,LEVEL) = FLUX(J,LEVEL) + LWMAST1A.305
& TRANS(J,BAND) * DB(J,LEVEL,BAND,1) LWMAST1A.306
FLUX(J,LEVEL+1) = FLUX(J,LEVEL+1) + LWMAST1A.307
& TRANS(J,BAND) * DB(J,LEVEL,BAND,2) LWMAST1A.308
23 CONTINUE LWMAST1A.309
ELSE !IF (LEVEL.EQ.NLEVS) LWMAST1A.310
C ! except right at the top, where the toa flux gets special LWMAST1A.311
C ! treatment (no transmissivity): LWMAST1A.312
DO 24 BAND=1, NBANDS LWMAST1A.313
Cfpp$ Select(CONCUR) LWMAST1A.314
DO 24 J=1, L2 LWMAST1A.315
FLUX(J,LEVEL) = FLUX(J,LEVEL) + LWMAST1A.316
& TRANS(J,BAND) * DB(J,LEVEL,BAND,1) LWMAST1A.317
FLUX(J,NLEVS+1) = FLUX(J,NLEVS+1) + DB(J,NLEVS,BAND,2) LWMAST1A.318
IF ( CSOLON ) CSOLRD(J) = CSOLRD(J) - DB(J,NLEVS,BAND,2) LWMAST1A.319
24 CONTINUE LWMAST1A.320
ENDIF LWMAST1A.321
IF ( CSSDON .AND. LEVEL .EQ. 1 ) THEN LWMAST1A.322
DO 221 BAND=1, NBANDS LWMAST1A.323
Cfpp$ Select(CONCUR) LWMAST1A.324
DO J=1, L2 LWMAST1A.325
CSSFDN(J) = CSSFDN(J) + TRANS(J,BAND) * DB(J,LEVEL,BAND,1) LWMAST1A.326
ENDDO LWMAST1A.327
221 CONTINUE LWMAST1A.328
ENDIF LWMAST1A.329
2 CONTINUE LWMAST1A.330
CL LWMAST1A.331
CL ! Separate DB for each half-layer are needed for the "half-layer" LWMAST1A.332
CL ! terms and the cloud boundary (and surface) source terms. Now LWMAST1A.333
CL ! the "half-layer" terms have been dealt with, they can be LWMAST1A.334
CL ! combined above all clouds, to save calculations later in the LWMAST1A.335
CL ! "DO 36" loop. LWMAST1A.336
CL LWMAST1A.337
DO 20 BAND=1, NBANDS LWMAST1A.338
DO 20 LEVEL=NCLDS+1, NLEVS-1 LWMAST1A.339
Cfpp$ Select(CONCUR) LWMAST1A.340
DO 20 J=1, L2 LWMAST1A.341
DB(J,LEVEL,BAND,2) = DB(J,LEVEL,BAND,2) + DB(J,LEVEL+1,BAND,1) LWMAST1A.342
20 CONTINUE LWMAST1A.343
CL LWMAST1A.344
CL ! SECTION 3 LWMAST1A.345
CL LWMAST1A.346
CL ! Now have the full-level terms to find, with a contribution from LWMAST1A.347
CL ! every layer boundary to the flux at every other layer boundary. LWMAST1A.348
CL LWMAST1A.349
C ! The contributions from each of a pair of layers to the other are LWMAST1A.350
C ! added in at once so that transmissivities or pathlengths do not LWMAST1A.351
C ! have to be stored for all combinations nor calculated twice. LWMAST1A.352
C ! LEVEL and LEVEL2 are the lower and upper layer boundaries LWMAST1A.353
C ! respectively. Layer boundaries are conventionally indexed by LWMAST1A.354
C ! half-integers in the documentation, and so for FORTRAN we must LWMAST1A.355
C ! add or subtract a half. LWMAST1A.356
C ! We currently add it, so the numerical value of LEVEL is the LWMAST1A.357
C ! number of the layer centre ABOVE it, consistent with the LWMAST1A.358
C ! indexing of most arrays (not ECTA, which is indexed by LEVEL-1) LWMAST1A.359
C LWMAST1A.360
*IF DEF,RANDOVER LWMAST1A.361
C ! The source term for the downward flux (i.e. from the upper layer LWMAST1A.362
C ! boundary, LEVEL2), DNSRCE, is needed on different passes through LWMAST1A.363
C ! the outer "DO 3" loop, so that the whole lot is precalculated LWMAST1A.364
C ! and stored, but the upward one, UPSRCE, is only needed for the LWMAST1A.365
C ! current value of LEVEL. The calculations are complicated by the LWMAST1A.366
C ! need to take account of clouds more than one level thick. This LWMAST1A.367
C ! means that over part of the grid-box neither the half-level dB LWMAST1A.368
C ! (for cloud top or bottom) nor the full-level one (for cloud-free LWMAST1A.369
C ! space) may need to be added in. This is not easily allowed for LWMAST1A.370
C ! by CLRF alone. The method adopted is to normalize UPSRCE and LWMAST1A.371
C ! DNSRCE to be the mean dB terms from the parts of the layer LWMAST1A.372
C ! boundary which do contribute, and initialize CLRF to CLDCLB LWMAST1A.373
C ! to take account of the effect of any cloud that does cross the LWMAST1A.374
C ! layer boundary at LEVEL. LWMAST1A.375
*ENDIF RANDOVER LWMAST1A.376
DO 3 LEVEL=1, NLEVS LWMAST1A.377
C ! Start by setting the pathlength to that for the layer above the LWMAST1A.378
C ! layer boundary where FLUX(,LEVEL) applies, and also initialize LWMAST1A.379
C ! overlap quantities. LWMAST1A.380
DO 31 GAS=1, NGASES LWMAST1A.381
Cfpp$ Select(CONCUR) LWMAST1A.382
DO 31 J=1, L2 LWMAST1A.383
PATH(J,GAS) = DPATH(J,GAS,LEVEL) LWMAST1A.384
31 CONTINUE LWMAST1A.385
DO 32 BAND=1, NBANDS LWMAST1A.386
Cfpp$ Select(CONCUR) LWMAST1A.387
DO 32 J=1, L2 LWMAST1A.388
*IF DEF,RANDOVER LWMAST1A.389
IF (LEVEL.EQ.1) THEN LWMAST1A.390
UPSRCE(J,BAND) = DB(J,1,BAND,1) LWMAST1A.391
CLRF(J,BAND) = 1. LWMAST1A.392
ELSE IF (LEVEL.LE.(NCLDS+1)) THEN LWMAST1A.393
CLDCLB = ECA(J,LEVEL-1,BAND) + ECTA(J,LEVEL-1,BAND) LWMAST1A.394
UPSRCE(J,BAND) = DB(J,LEVEL,BAND,1) LWMAST1A.395
& + ECA(J,LEVEL-1,BAND) * DB(J,LEVEL-1,BAND,2) / CLDCLB LWMAST1A.396
CLRF(J,BAND) = CLDCLB LWMAST1A.397
ELSE ! IF LEVEL > NCLDS + 1 LWMAST1A.398
UPSRCE(J,BAND) = DB(J,LEVEL-1,BAND,2) LWMAST1A.399
CLRF(J,BAND) = 1. LWMAST1A.400
ENDIF LWMAST1A.401
*ELSE RANDOVER LWMAST1A.402
C LWMAST1A.403
IF ( LEVEL .GT. NCLDS+1 ) LWMAST1A.404
& UPSRCE(J,BAND) = DB(J,LEVEL-1,BAND,2) LWMAST1A.405
Combine with the RANDOVER code above when (if?) have "DO 30" same LWMAST1A.406
NOCLRB(J) = .TRUE. LWMAST1A.407
IF ( LEVEL .LE. NCLDS ) LWMAST1A.408
& DNCLRF(J,BAND) = MIN ( 1., ECA(J,LEVEL,BAND) ) LWMAST1A.409
C ! This is really to initialize DNCLRO LWMAST1A.410
IF (LEVEL.EQ.1) THEN LWMAST1A.411
UPCLRF(J,BAND) = 0. ! Out if ECA(,0,)=0 LWMAST1A.412
ELSE IF ( LEVEL .LE. NCLDS+1 ) THEN WI200893.7
UPCLRF(J,BAND) = ECA(J,LEVEL-1,BAND) LWMAST1A.414
ENDIF LWMAST1A.415
UPCLDF(J,BAND) = 1. - UPCLRF(J,BAND) LWMAST1A.416
*ENDIF RANDOVER LWMAST1A.417
32 CONTINUE LWMAST1A.418
*IF DEF,RANDOVER LWMAST1A.419
DO 30 LEVEL2=LEVEL+1, NCLDS LWMAST1A.420
*ELSE RANDOVER LWMAST1A.421
DO 30 LEVEL2=LEVEL+1, NCLDS+1 LWMAST1A.422
LEVELA = MIN(LEVEL2,NCLDS) WI200893.8
*ENDIF RANDOVER LWMAST1A.423
CALL LWTRAN (PATH, LUT, LUT(1,1,1,2), FLSTBD, KCONT, LWMAST1A.424
& L2, GSS1F402.51
& TRANS) LWMAST1A.428
IF ( CSSDON .AND. LEVEL .EQ. 1 ) THEN LWMAST1A.429
DO 363 BAND=1, NBANDS LWMAST1A.430
Cfpp$ Select(CONCUR) LWMAST1A.431
DO J=1, L2 LWMAST1A.432
CSSFDN(J) = CSSFDN(J) + LWMAST1A.433
& TRANS(J,BAND) * ( DB(J,LEVEL2,BAND,1) + DB(J,LEVEL2-1,BAND,2) ) LWMAST1A.434
ENDDO LWMAST1A.435
363 CONTINUE LWMAST1A.436
ENDIF LWMAST1A.437
DO 33 BAND=1, NBANDS LWMAST1A.438
Cfpp$ Select(CONCUR) LWMAST1A.439
DO 33 J=1, L2 LWMAST1A.440
*IF DEF,RANDOVER LWMAST1A.441
C ! Since this code works up from LEVEL, a cloud starts having LWMAST1A.442
C ! an effect on the overlaps (other than through CLDCLB) when LWMAST1A.443
C ! its base is reached, and its effect is constant thereafter. LWMAST1A.444
CLDCLB = ECA(J,LEVEL2-1,BAND) + ECBA(J,LEVEL2-1,BAND) LWMAST1A.445
CLRF(J,BAND) = CLRF(J,BAND) * LWMAST1A.446
& ( 1. - ECBA(J,LEVEL2-1,BAND) / CLDCLB ) LWMAST1A.447
EFFTRA = TRANS(J,BAND) * CLRF(J,BAND) LWMAST1A.448
C LWMAST1A.449
FLUX(J,LEVEL) = FLUX(J,LEVEL) + EFFTRA * DNSRCE(J,BAND,LEVEL2) LWMAST1A.450
FLUX(J,LEVEL2) = FLUX(J,LEVEL2) + EFFTRA * UPSRCE(J,BAND) LWMAST1A.451
*ELSE RANDOVER LWMAST1A.452
DNCLRO = DNCLRF(J,BAND) LWMAST1A.453
IF (ECA(J,LEVEL2-1,BAND).EQ.1.) THEN LWMAST1A.454
DNCLRO = 1. LWMAST1A.455
NOCLRB(J) = .FALSE. LWMAST1A.456
ENDIF LWMAST1A.457
IF (LEVEL2.LT.NCLDS+1) THEN LWMAST1A.458
DNCLRF(J,BAND) = MIN ( ECA(J,LEVEL2,BAND), DNCLRO ) LWMAST1A.459
ELSE LWMAST1A.460
DNCLRF(J,BAND) = DNCLRO LWMAST1A.461
ENDIF LWMAST1A.462
DNCLDF = DNCLRO - DNCLRF(J,BAND) LWMAST1A.463
C ! = MAX ( 0, (1-ECA) - (1-DNCLRO) ) LWMAST1A.464
IF (NOCLRB(J)) THEN LWMAST1A.465
IF (LEVEL.GT.1) THEN ! Out if ECA(,0,)=0 LWMAST1A.466
UPCLRF(J,BAND) = MIN ( ECA(J,LEVEL-1,BAND), DNCLRO ) LWMAST1A.467
ELSE LWMAST1A.468
UPCLRF(J,BAND) = 0. LWMAST1A.469
ENDIF LWMAST1A.470
UPCLDF(J,BAND) = DNCLRO - UPCLRF(J,BAND) LWMAST1A.471
C ! = MAX ( 0., (1-ECA) - (1-DNCLRO) ) LWMAST1A.472
ENDIF LWMAST1A.473
C LWMAST1A.474
C ! This suggests simplification is desirable... LWMAST1A.475
F1CON = DNCLRF(J,BAND) * DB(J,LEVEL2,BAND,1) LWMAST1A.476
& + ( DNCLRF(J,BAND)+DNCLDF ) * DB(J,LEVEL2-1,BAND,2) LWMAST1A.477
F2CON = ( UPCLRF(J,BAND)+UPCLDF(J,BAND) ) * DB(J,LEVEL,BAND,1) LWMAST1A.478
IF ( LEVEL .GT. 1 ) LWMAST1A.479
& F2CON = F2CON + UPCLRF(J,BAND) * DB(J,LEVEL-1,BAND,2) LWMAST1A.480
IF (.NOT.NOCLRB(J)) THEN LWMAST1A.481
F1CON = F1CON * ( UPCLRF(J,BAND) + UPCLDF(J,BAND) ) LWMAST1A.482
F2CON = F2CON * DNCLRO LWMAST1A.483
ENDIF LWMAST1A.484
C LWMAST1A.485
FLUX(J,LEVEL) = FLUX(J,LEVEL) + TRANS(J,BAND) * F1CON LWMAST1A.486
FLUX(J,LEVEL2) = FLUX(J,LEVEL2) + TRANS(J,BAND) * F2CON LWMAST1A.487
C LWMAST1A.488
C NCLDS+1 bit may not vectorize well - but will probably shift it later LWMAST1A.489
IF ( (LEVEL2 .EQ. NCLDS+1 .OR. ECA(J,LEVELA,BAND).EQ.1.) WI200893.9
& .AND. .NOT.NOCLRB(J)) THEN LWMAST1A.491
UPCLDF(J,BAND) = UPCLDF(J,BAND) * DNCLRO LWMAST1A.492
UPCLRF(J,BAND) = UPCLRF(J,BAND) * DNCLRO LWMAST1A.493
ENDIF LWMAST1A.494
*ENDIF RANDOVER LWMAST1A.495
C LWMAST1A.496
33 CONTINUE LWMAST1A.497
C ! Add in the next layer's contributions to the gas pathlengths. LWMAST1A.498
DO 34 GAS=1, NGASES LWMAST1A.499
Cfpp$ Select(CONCUR) LWMAST1A.500
DO 34 J=1, L2 LWMAST1A.501
PATH(J,GAS) = PATH(J,GAS) + DPATH(J,GAS,LEVEL2) LWMAST1A.502
34 CONTINUE LWMAST1A.503
30 CONTINUE LWMAST1A.504
C ! For layers above all cloud, use the last values of the LWMAST1A.505
C ! cloud overlap terms (or the initialized ones if LEVEL>=NCLDS) LWMAST1A.506
C ! - otherwise the physics is the same. LWMAST1A.507
FSCLYR=LEVEL2 ! Next layer boundary to do is LWMAST1A.508
*IF DEF,RANDOVER LWMAST1A.509
C ! MAX(NCLDS+1,LEVEL+1), where there cannot be a cloud term in the LWMAST1A.510
C ! downward source, but there may still be for CLRF LWMAST1A.511
IF (LEVEL.LE.NCLDS) THEN LWMAST1A.512
DO 35 BAND=1, NBANDS LWMAST1A.513
Cfpp$ Select(CONCUR) LWMAST1A.514
DO 35 J=1, L2 LWMAST1A.515
CLRF(J,BAND) = CLRF(J,BAND) * (1.-ECBA(J,NCLDS,BAND)) LWMAST1A.516
35 CONTINUE LWMAST1A.517
ENDIF LWMAST1A.518
*ELSE RANDOVER LWMAST1A.519
C ! MAX(NCLDS+2,LEVEL+1), the lowest where no cloud terms occur LWMAST1A.520
C ! (though the downward source already has none at NCLDS+1, and so LWMAST1A.521
C ! needed special treatment above). LWMAST1A.522
IF (LEVEL.LE.NCLDS+1) THEN LWMAST1A.523
LEVELA = MAX(LEVEL-1,1) WI200893.10
DO 35 BAND=1, NBANDS LWMAST1A.524
Cfpp$ Select(CONCUR) LWMAST1A.525
DO 35 J=1, L2 LWMAST1A.526
UPSRCE(J,BAND) = UPCLRF(J,BAND) * DB(J,LEVELA,BAND,2) + WI200893.11
& ( UPCLRF(J,BAND) + UPCLDF(J,BAND) ) * DB(J,LEVEL,BAND,1) LWMAST1A.528
Could do: IF (.NOT.NOCLRB(J)) LWMAST1A.529
C & UPSRCE(J,BAND) = UPSRCE(J,BAND) * DNCLRO LWMAST1A.530
C here rather than before l 33 - esp if take DO 30 loop to NCLDS only LWMAST1A.531
35 CONTINUE LWMAST1A.532
ENDIF LWMAST1A.533
*ENDIF RANDOVER LWMAST1A.534
DO 38 LEVEL2=FSCLYR, NLEVS+1 LWMAST1A.535
CALL LWTRAN (PATH, LUT, LUT(1,1,1,2), FLSTBD, KCONT, LWMAST1A.536
& L2, GSS1F402.52
& TRANS) LWMAST1A.540
IF ( CSSDON .AND. LEVEL .EQ. 1 ) THEN LWMAST1A.541
DO 366 BAND=1, NBANDS LWMAST1A.542
Cfpp$ Select(CONCUR) LWMAST1A.543
DO J=1, L2 LWMAST1A.544
CSSFDN(J) = LWMAST1A.545
& CSSFDN(J) + TRANS(J,BAND) * DB(J,LEVEL2-1,BAND,2) LWMAST1A.546
*IF DEF,RANDOVER LWMAST1A.547
IF ( LEVEL2 .EQ. NCLDS+1 ) CSSFDN(J) = LWMAST1A.548
& CSSFDN(J) + TRANS(J,BAND) * DB(J,LEVEL2,BAND,1) LWMAST1A.549
*ENDIF RANDOVER LWMAST1A.550
ENDDO LWMAST1A.551
366 CONTINUE LWMAST1A.552
ENDIF LWMAST1A.553
DO 36 BAND=1, NBANDS LWMAST1A.554
Cfpp$ Select(CONCUR) LWMAST1A.555
DO 36 J=1, L2 LWMAST1A.556
C LWMAST1A.557
*IF DEF,RANDOVER LWMAST1A.558
EFFTRA = TRANS(J,BAND) * CLRF(J,BAND) LWMAST1A.559
FLUX(J,LEVEL) = FLUX(J,LEVEL) + EFFTRA * DB(J,LEVEL2-1,BAND,2) LWMAST1A.560
IF ( LEVEL2 .EQ. NCLDS+1 ) LWMAST1A.561
& FLUX(J,LEVEL) = FLUX(J,LEVEL) + EFFTRA * DB(J,LEVEL2,BAND,1) LWMAST1A.562
FLUX(J,LEVEL2) = FLUX(J,LEVEL2) + EFFTRA * UPSRCE(J,BAND) LWMAST1A.563
*ELSE RANDOVER LWMAST1A.564
FLUX(J,LEVEL) = FLUX(J,LEVEL) + TRANS(J,BAND) * LWMAST1A.565
& ( UPCLDF(J,BAND) + UPCLRF(J,BAND) ) * DB(J,LEVEL2-1,BAND,2) LWMAST1A.566
C LWMAST1A.567
FLUX(J,LEVEL2) = FLUX(J,LEVEL2) LWMAST1A.568
& + TRANS(J,BAND) * UPSRCE(J,BAND) LWMAST1A.569
*ENDIF RANDOVER LWMAST1A.570
C LWMAST1A.571
36 CONTINUE LWMAST1A.572
IF (LEVEL2.LT.NLEVS+1) THEN LWMAST1A.573
C ! Add in the next contribution to the gas pathlengths. LWMAST1A.574
DO 37 GAS=1, NGASES LWMAST1A.575
Cfpp$ Select(CONCUR) LWMAST1A.576
DO 37 J=1, L2 LWMAST1A.577
PATH(J,GAS) = PATH(J,GAS) + DPATH(J,GAS,LEVEL2) LWMAST1A.578
37 CONTINUE LWMAST1A.579
ENDIF LWMAST1A.580
38 CONTINUE LWMAST1A.581
CL ! Put in the contributions to CSOLRD: LWMAST1A.582
IF ( CSOLON ) THEN LWMAST1A.583
DO 39 BAND=1, NBANDS LWMAST1A.584
DO J=1, L2 LWMAST1A.586
IF ( LEVEL .LE. NCLDS+1 ) CSOLRD(J) = CSOLRD(J) - LWMAST1A.587
& TRANS(J,BAND) * DB(J,LEVEL,BAND,1) LWMAST1A.588
IF ( LEVEL .GT. 1 ) CSOLRD(J) = CSOLRD(J) - LWMAST1A.589
& TRANS(J,BAND) * DB(J,LEVEL-1,BAND,2) LWMAST1A.590
ENDDO LWMAST1A.591
39 CONTINUE LWMAST1A.592
ENDIF LWMAST1A.593
3 CONTINUE LWMAST1A.594
C LWMAST1A.595
C LWMAST1A.596
CL ! Change CSSFDN from the net downward flux which has been found LWMAST1A.597
CL ! so far to the downward flux wanted: LWMAST1A.598
IF ( CSSDON ) THEN LWMAST1A.599
DO J=1, L2 LWMAST1A.600
CSSFDN(J) = SFDN(J) + CSSFDN(J) LWMAST1A.601
ENDDO LWMAST1A.602
ENDIF LWMAST1A.603
C LWMAST1A.604
CL ! Change SFDN from the upward flux returned by LWPLAN to the LWMAST1A.605
CL ! downward flux wanted: LWMAST1A.606
IF ( SFDNON ) THEN LWMAST1A.607
DO J=1, L2 LWMAST1A.608
SFDN(J) = SFDN(J) + FLUX(J,1) LWMAST1A.609
ENDDO LWMAST1A.610
ENDIF LWMAST1A.611
RETURN LWMAST1A.612
END LWMAST1A.613
*ENDIF A02_1A,OR,A02_1B LWMAST1A.614