SUBROUTINE SWRAD (H2OIN, CO2, O3IN, PSTIN, ABIN, BBIN, LCAIN, 3,10SWRAD2B.56
& LCW1IN, LCW2IN, CCAIN, CCWPIN, CCBIN, CCTIN, SALIIN, SAOSIN, SWRAD2B.57
& AICE, COSZIN, LIT, LAND, LIST, TAC, SCS, LUT, PTS, SANAIN, SWRAD2B.58
& OSDIA, OSON, CSOSDI, CSOSON, NSSB1, NSS1ON, TDSS, TDSSON, SWRAD2B.59
& CSSSD, CSSSDO, CSSSU, CSSSUO, LCASW, LCASWO, CCASW, CCASWO, SWRAD2B.60
& LCAAR, LCAARO, LCAARL, LCAARB, LCAAF, LCAAFO, LCAAFL, LCAAFB, SWRAD2B.61
& CCAAR, CCAARO, CCAARB, CCAAF, CCAAFO, CCAAFB, TCASW, TCASWO, SWRAD2B.62
& CREFF, CREFFO, LREFF, LREFFO, CVAMT, CVAMTO, LRAMT, LRAMTO, SWRAD2B.63
& CWPAJ, CWPAJON, MICRO, SO4_FORCE, SO4_FORCE_ON, SWRAD2B.64
& NLALBS, NAADIM, AWI1F403.402
& LCA3L, LCA3ON, LCLD3, SWRAD2B.65
& L_CLOUD_WATER_PARTITION, AYY1F404.294
& NLIT, NDO, NLEVS, NCLDS, NWET, NOZONE, L1, SWRAD2B.66
& NTSWIN, SWSEA, SWOUT) SWRAD2B.67
EXTERNAL SWMAST, SWDTCA, LSP_FOCWWIL SWRAD2B.68
C* SWRAD2B.69
! EITHER AYY1F404.295
! Use temperature dependent focwwil for convection but calculate AYY1F404.296
! ratio in layer cloud from prognostic cloud ice produce as part AYY1F404.297
! of large-scale precipitation scheme 3A, OR AYY1F404.298
! Use the subroutine LSP_FOCWWIL (from Section 4) consistently to SWRAD2B.70
C ! derive cloud radiative properties and precipitation amount, SWRAD2B.71
C ! taking into account that cloud does not freeze as soon as it is SWRAD2B.72
C ! cooled below the freezing point of bulk water. The release of SWRAD2B.73
C ! latent heat of fusion (not a major term) is done differently in SWRAD2B.74
C ! order to allow energy conservation (UMDP 29). This is the SWRAD2B.75
C ! reason for two layer cloud water contents being passed in and SWRAD2B.76
C ! then combined and differently split. SWRAD2B.77
C SWRAD2B.78
C ! Dimensions: SWRAD2B.79
*CALL SWNBANDS 
SWRAD2B.80
*CALL SWNGASES SWRAD2B.81
*CALL SWNTRANS SWRAD2B.82
*CALL SWLKUPPA SWRAD2B.83
C*IF -DEF,CRAY SWRAD2B.84
INTEGER!, INTENT(IN) :: SWRAD2B.85
& L1, ! Number of points in input arrays SWRAD2B.86
& NDO, ! Number of points to be treated SWRAD2B.87
& NAADIM, ! Number of points to assign AWI1F403.403
! storage for SANAGI at - this is workspace used only if SO4_FORCE_ON AWI1F403.404
& NLALBS, ! Number of fields of land surface AWI1F403.405
C ! albedo - 2 if different for direct & diffuse sunlight, 1 if not AWI1F403.406
& NLEVS, ! Number of levels SWRAD2B.89
& NCLDS, ! Number of possibly cloudy levels SWRAD2B.90
& NWET, ! Number of levels with water vapor SWRAD2B.91
& NOZONE ! Number of levels with ozone SWRAD2B.92
C*ELSE SWRAD2B.93
C INTEGER L1, NLIT, NDO ! Array sizes must be constant SWRAD2B.94
C PARAMETER (NLIT=1, L1=1, NDO=1) ! Make it an SCM SWRAD2B.95
C*CALL NLEVSVAL SWRAD2B.96
C*CALL NCLDSVAL SWRAD2B.97
C*CALL NWETVAL SWRAD2B.98
C*CALL NOZONVAL SWRAD2B.99
C*ENDIF SWRAD2B.100
C ! Physical inputs: SWRAD2B.101
REAL!, INTENT(IN) :: SWRAD2B.102
& H2OIN(L1,NWET), CO2, ! Mass mixing ratios of SWRAD2B.103
& O3IN(L1,NOZONE), ! absorbing gases SWRAD2B.104
& PSTIN(L1), ! Surface pressure SWRAD2B.105
& ABIN(NLEVS+1), BBIN(NLEVS+1), ! As and Bs at layer boundaries SWRAD2B.106
& LCAIN(L1,1/(NCLDS+1)+NCLDS), ! Layer cloud fractional cover SWRAD2B.107
& LCW1IN(L1,1/(NCLDS+1)+NCLDS), ! Layer cloud frozen and liquid SWRAD2B.108
& LCW2IN(L1,1/(NCLDS+1)+NCLDS), ! water contents SWRAD2B.109
C ! These are specific cloud water contents, mass per unit mass, SWRAD2B.110
C ! and, as explained above, only their sum is used. SWRAD2B.111
& CCAIN(L1), ! Convective Cloud Amount SWRAD2B.112
& CCWPIN(L1), ! and condensed water path SWRAD2B.113
& SALIIN(L1,NLALBS), ! (True) Surface Albedo for AWI1F403.407
& SAOSIN(L1,2), ! land & ice, for & open sea SWRAD2B.115
& SANAIN(L1,2), ! & for no aerosol SWRAD2B.116
& COSZIN(L1), ! Mean (cos solar zenith angle) SWRAD2B.117
C ! while the point is sunlit SWRAD2B.118
& LIT(L1), ! Fraction the point is sunlit SWRAD2B.119
& TAC(L1,NLEVS), ! Atmospheric temperatures SWRAD2B.120
& AICE(L1), ! Sea-ice fraction SWRAD2B.121
& SCS, ! Solar Constant Scaling factor SWRAD2B.122
C ! - inverse-square factor which multiplies the solar constant to SWRAD2B.123
C ! get the normal solar irradiance at this day's earth-sun distance SWRAD2B.124
& LUT(NLKUPS,NTRANS,NGASES,2), SWRAD2B.125
C ! Look-up tables of transmissivities for each gas and of SWRAD2B.126
C ! differences of their successive elements. SWRAD2B.127
& PTS ! Time interval at which the SWRAD2B.128
C ! increments to be returned are to be added in ("physics SWRAD2B.129
C ! timestep"). The time interval over which they are valid SWRAD2B.130
C ! ("shortwave timestep") is not used directly here, but as an SWRAD2B.131
C ! input to the astronomy code it affects COSZIN, LIT and LIST. SWRAD2B.132
INTEGER!, INTENT(IN) :: SWRAD2B.133
& LIST(NLIT), ! List of the NLIT sunlit points SWRAD2B.134
& CCBIN(L1), ! Convective cloud base & top, SWRAD2B.135
& CCTIN(L1) ! layer boundaries counting up from SWRAD2B.136
C ! the surface as 1 SWRAD2B.137
C ! Control quantities: SWRAD2B.138
LOGICAL!, INTENT(IN) :: SWRAD2B.139
& LAND(L1) ! Land/sea mask (.TRUE. for land) SWRAD2B.140
& , OSON, CSOSON ! Are OSDIA & CSOSDI wanted ? SWRAD2B.141
& , NSS1ON, TDSSON ! And are NSSSB1 and TDSS ? SWRAD2B.142
& , CREFFO, LREFFO ! And are CREFF and LREFF... SWRAD2B.143
& , CVAMTO, LRAMTO ! ... and CVAMT and LRAMT ? SWRAD2B.144
& , SO4_FORCE_ON ! & is SO4_FORCE ? SWRAD2B.145
& , CWPAJON ! Is CWP O/P wanted? SWRAD2B.146
& , MICRO ! Is microphysics code activated? SWRAD2B.147
& , LCA3ON ! And is LCA3L ? SWRAD2B.148
C ! Note that if LCLD3, LCA3L is needed to calculate TCASW & so SWRAD2B.149
C ! will be calculated whenever TCASWO or LCA3ON - so space must SWRAD2B.150
C ! then be available (via "implied diagnostics" in the std UM). SWRAD2B.151
& , CSSSDO, CSSSUO ! & are CSSSD & CSSSU, SWRAD2B.152
& , LCASWO, CCASWO ! LCASW & CCASW, SWRAD2B.153
& , LCAARO, LCAAFO ! LCAAR & LCAAF, SWRAD2B.154
& , CCAARO, CCAAFO ! CCAAR & CCAAF, SWRAD2B.155
& , TCASWO ! & TCASW ? SWRAD2B.156
& , LCAARL(NCLDS), LCAARB(NBANDS), LCAAFL(NCLDS) SWRAD2B.157
& , LCAAFB(NBANDS), CCAARB(NBANDS), CCAAFB(NBANDS) SWRAD2B.158
C ! If L/C CAA R/F are wanted, for which (levels and) bands ? SWRAD2B.159
& , LCLD3 SWRAD2B.160
& , L_CLOUD_WATER_PARTITION AYY1F404.299
C ! And outputs: SWRAD2B.161
REAL!, INTENT(OUT) :: SWRAD2B.162
& SWOUT(L1,NLEVS+2), ! This is filled by SWMAST with the SWRAD2B.163
C ! normalized net downward shortwave flux at all layer boundaries. SWRAD2B.164
C ! SWRAD multiplies them by the normal incoming insolation to give SWRAD2B.165
C ! dimensioned fluxes (still not the actual fluxes as the cosz SWRAD2B.166
C ! term is not put in here) and differences them in the vertical SWRAD2B.167
C ! to give SW heating rates (except for the cosz) in each SWRAD2B.168
C ! atmospheric layer, leaving a surface net downward SW flux in SWRAD2B.169
C ! the first level for use in the surface scheme. It also SWRAD2B.170
C ! modifies the latter so that it refers to land-and-ice only (the SWRAD2B.171
C ! surfaces dealt with in the atmospheric model), being the value SWRAD2B.172
C ! over that surface (except the cosz) times the fraction of the SWRAD2B.173
C ! grid-box covered by land or sea-ice. SWRAD2B.174
C ! The 'level' NLEV+2 holds NSSB1 without Zenith Angle SWRAD2B.175
C ! adjustment,for use in physics timesteps in RAD_CTL and CLD_CTL SWRAD2B.176
& SWSEA(L1) ! The net downward SW flux over SWRAD2B.177
C ! open sea. SWMAST returns this normalized and SWRAD converts SWRAD2B.178
C ! it into an actual flux with weighting by the open sea fraction SWRAD2B.179
C ! (so that it can be added to the corresponding land-and-ice SWRAD2B.180
C ! term to give the overall net downward SW flux.) SWRAD2B.181
& , NTSWIN(L1) ! Net SW absorption by the planet SWRAD2B.182
& , OSDIA(L1) ! Diagnosed actual and clear-sky SWRAD2B.183
& , CSOSDI(L1) ! outgoing solar at toa SWRAD2B.184
& , CSSSD(L1) ! Clear-sky total downward & SWRAD2B.185
& , CSSSU(L1) ! upward SW flux at the surface SWRAD2B.186
& , LCASW(L1,NCLDS) ! Layer/Convective Cloud Amount SWRAD2B.187
& , CCASW(L1) ! in SW (zero at night points) SWRAD2B.188
& , LCAAR(L1,*) ! Layer/Convective Cloud Amount * SWRAD2B.189
& , LCAAF(L1,*) ! Albedo to diRect and diFfuse SWRAD2B.190
& , CCAAR(L1,*) ! light (set to zero at night SWRAD2B.191
& , CCAAF(L1,*) ! points) SWRAD2B.192
& , TCASW(L1) ! Total cloud amount in SW SWRAD2B.193
C ! (i.e. fraction of the grid-box with cloud at some level) SWRAD2B.194
& , NSSB1(L1) SWRAD2B.195
C ! Net downward SW flux at the surface in band 1 SWRAD2B.196
& , TDSS(L1) SWRAD2B.197
C ! Total downward SW flux at the surface (multiply-reflected SWRAD2B.198
C ! light being multiply counted). SWRAD2B.199
& , TDSSB1(L1) SWRAD2B.200
C ! Total downward SW flux at surface in band 1 SWRAD2B.201
& , CREFF(L1) ! Convective cloud rE * cld amount SWRAD2B.202
& , LREFF(L1,NCLDS) ! Layer cloud rE * cld amount SWRAD2B.203
& , CVAMT(L1) ! Convective cloud amount in SWRAD SWRAD2B.204
& , LRAMT(L1,NCLDS) ! Layer cloud amount in SWRAD SWRAD2B.205
& , CWPAJ(L1,NCLDS) ! Lyr cld CWP for 3-cld scheme SWRAD2B.206
& , LCA3L(L1,NCLDS) ! Diagnostic of layer cloud amount SWRAD2B.207
C ! restricted to 3 layers, calculated at all points on SW timesteps SWRAD2B.208
& , SO4_FORCE(L1) ! Diagnostic of radiative forcing SWRAD2B.209
C ! due to the change in surface albedo from SANA to SALI/SAOS. SWRAD2B.210
C* SWRAD2B.211
C ! Constants: SWRAD2B.212
*CALL C_0_DG_C SWRAD2B.213
*CALL C_R_CP SWRAD2B.214
*CALL C_G SWRAD2B.215
*CALL C_PI SWRAD2B.216
*CALL C_DENSTY SWRAD2B.217
*CALL C_MICRO SWRAD2B.218
REAL CPBYG ! Helps convert fluxes to SWRAD2B.219
PARAMETER ( CPBYG = CP / G ) ! heating rates SWRAD2B.220
*CALL SWSC SWRAD2B.221
*CALL SWRE SWRAD2B.222
REAL COSMIN ! Minimum value for COSZ, to SWRAD2B.223
PARAMETER ( COSMIN = 1.E-4 ) ! avoid underflow in SWCLOP SWRAD2B.224
C ! Local variables: SWRAD2B.225
REAL NSI, ! Normal Solar Irradiance SWRAD2B.226
& TEMPOR, ! Temporary store SWRAD2B.227
& DACON1, DBCON1, ! Conversion factors for turning SWRAD2B.228
C ! fluxes into increments - difference of As and Bs across the SWRAD2B.229
C ! current layer, times CPBYG and divided by the timestep. SWRAD2B.230
& DACON2, DBCON2 ! Conversion factors for turning SWRAD2B.231
C ! mixing ratio into pathlength - difference of As and Bs across SWRAD2B.232
C ! the current layer, divided by g. SWRAD2B.233
REAL DCONRE, ! Cloud droplet rE for deep convective clouds. SWRAD2B.234
& SCONRE, ! " " " " shallow " " . SWRAD2B.235
& NTOT, ! Total CCN concentration (/m**3). SWRAD2B.236
& KPARAM, ! k parameter (=rV/rE). SWRAD2B.237
& PCCTOP, ! Convective cloud top pressure. SWRAD2B.238
& PCCBOT, ! " " base " . SWRAD2B.239
& LCMMR, ! Layer cloud mass mixing ratio (kg/kg). SWRAD2B.240
& LWC, ! Cloud liquid water content (kg/m**3). SWRAD2B.241
& RHOAIR, ! Local density of air (kg/m**3). SWRAD2B.242
& DELTAZ, ! Thickness of convective cloud (m). SWRAD2B.243
& PRESS1, ! Pressure at bottom... SWRAD2B.244
& PRESS2, ! ...and top of layer boundaries. SWRAD2B.245
& TAU, ! Area-averaged optical depth. SWRAD2B.246
& L1AJ ! Cloud amount dummy-variable. SWRAD2B.247
C SWRAD2B.248
C*L SWRAD2B.249
CL ! Dynamically allocated workspace: SWRAD2B.250
C ! 3*NDO+ NLIT*(3*NCLDS+NWET+NOZONE+4*NBANDS+8) +2*(NLEVS+1) SWRAD2B.251
REAL H2OGI(NLIT,NWET), ! Gathered and inverted inputs: SWRAD2B.252
& O3GI(NLIT,NOZONE), ! just as the corresponding SWRAD2B.253
& PSTGI(NLIT), ! ...IN arrays, except that the SWRAD2B.254
& ABGI(NLEVS+1), BBGI(NLEVS+1), ! two LCW arrays are combined, SWRAD2B.255
& LCAGI(NLIT,NCLDS), ! since the ice/liquid split is SWRAD2B.256
& LCWPGI(NLIT,NCLDS), ! done differently for SWRAD2B.257
& CCAGI(NLIT), ! radiation and precipitation SWRAD2B.258
& CCWPGI(NLIT), ! than for latent heat release, SWRAD2B.259
& COSZGI(NLIT), ! and also converted from cloud SWRAD2B.260
& SANAGI(NAADIM,NBANDS,2), ! water content to path. AWI1F403.408
& SAGI(NLIT,NBANDS,2), ! Gathered surface albedos for SWRAD2B.262
& SAOSGI(NLIT,NBANDS,2) ! each band, for the whole SWRAD2B.263
C ! grid-box and open sea only (for SWMAST to calculate SWSEA with) SWRAD2B.264
C SWRAD2B.265
INTEGER CCBGI(NLIT), ! Convective cloud base & top, SWRAD2B.266
& CCTGI(NLIT) ! layers counting down from the SWRAD2B.267
C ! top layer as 1 SWRAD2B.268
& , INDEX(NDO) SWRAD2B.269
C ! Index for maximum(input)/only(used) cloud cover for a "type" SWRAD2B.270
C ! (This, and MAXCLD below, are dimensioned NDO rather than NLIT SWRAD2B.271
C ! because full field size is used if LCA3L is wanted.) SWRAD2B.272
REAL CRE(NLIT), ! Equivalent radii calculated SWRAD2B.273
& LRE(NLIT,NCLDS), ! as functions of temperature. SWRAD2B.274
& LAYERE(NLIT,NCLDS), ! Liquid-only rE SWRAD2B.275
& CWPAJGI(NLIT,NCLDS), ! CWP gathered & inverted SWRAD2B.276
& MAXCLD(NDO), ! Maximum cloud cover & total SWRAD2B.277
& TOTCWC(NLIT), ! water content for a "type" SWRAD2B.278
& IITOA(NDO) ! Incoming Insolation at the SWRAD2B.279
C ! Top Of the Atmosphere SWRAD2B.280
C* SWRAD2B.281
INTEGER LEVEL, J, ! Loopers over level and point SWRAD2B.282
& BAND, ! and band. SWRAD2B.283
& OFFSET, ! Index for diagnostics SWRAD SWRAD2B.284
C ! returns (potentially) compressed, allowing just the bands or SWRAD2B.285
C ! level-and-band combinations wanted to be allocated and set. SWRAD2B.286
& DIRDIF, ! and direct/diffuse albedos SWRAD2B.287
& TYPE, ! & cloud "type" (H/M/L) SWRAD2B.288
& RANGE(3,2), ! The range of level numbers SWRAD2B.289
C ! (counting down from the highest potentially cloudy level) for SWRAD2B.290
C ! the 3 cloud "types" - i.e. the RANGE(n,1)th to RANGE(n,2)th SWRAD2B.291
C ! potentially cloudy levels are assigned to the nth cloud type. SWRAD2B.292
C ! The values are set by comparing model eta values with BOUNDS. SWRAD2B.293
& FSTLEV, ! The equivalent of RANGE for SWRAD2B.294
& LSTLEV, ! a particular cloud type, but SWRAD2B.295
C ! counting up from the surface SWRAD2B.296
& NCLEAR, ! NLEVS-NCLDS SWRAD2B.297
& NNIGHT, ! NDO-NLIT SWRAD2B.298
& NLP1B2 ! (NLEVS+1)/2 SWRAD2B.299
REAL BOUNDS(2), ! Eta values that define where SWRAD2B.300
C ! cloud changes from "high" to "medium", & from "medium" to "low" SWRAD2B.301
& ETA, ! Eta at the layer boundary SWRAD2B.302
C ! ! currently being checked SWRAD2B.303
& ETALST ! & the previous one SWRAD2B.304
& , FOCWWIL SWRAD2B.305
! Local value of Fraction Of Cloud Water Which Is Liquid SWRAD2B.306
& , TFOC SWRAD2B.307
! and the cloud temperature used to calculate it. SWRAD2B.308
LOGICAL SET ! Has RANGE been set yet ? SWRAD2B.309
DATA BOUNDS / .37, .79 / SWRAD2B.310
DATA SET / .FALSE. / SWRAD2B.311
SAVE RANGE, SET ! SET must be specified too as SWRAD2B.312
C ! FORTRAN requires a variable initialized by a DATA statement to SWRAD2B.313
C ! have the SAVE attribute only if its value has not changed. SWRAD2B.314
IF (MICRO) THEN SWRAD2B.315
SWRAD2B.316
C Zero effective radius arrays if diagnostics requested: SWRAD2B.317
IF (CREFFO) THEN SWRAD2B.318
DO II=1, NDO SWRAD2B.319
CREFF(II) = 0.0 SWRAD2B.320
END DO SWRAD2B.321
END IF SWRAD2B.322
IF (LREFFO) THEN SWRAD2B.323
DO JJ=1, NCLDS SWRAD2B.324
DO II=1, NDO SWRAD2B.325
LREFF(II,JJ) = 0.0 SWRAD2B.326
END DO SWRAD2B.327
END DO SWRAD2B.328
END IF SWRAD2B.329
C Zero Cloud-Amount-In-SWRAD arrays if diagnostics requested: SWRAD2B.330
IF (CVAMTO) THEN SWRAD2B.331
DO II=1, NDO SWRAD2B.332
CVAMT(II) = 0.0 SWRAD2B.333
END DO SWRAD2B.334
END IF SWRAD2B.335
IF (LRAMTO) THEN SWRAD2B.336
DO JJ=1, NCLDS SWRAD2B.337
DO II=1, NDO SWRAD2B.338
LRAMT(II,JJ) = 0.0 SWRAD2B.339
END DO SWRAD2B.340
END DO SWRAD2B.341
END IF SWRAD2B.342
C Zero Layer-Cloud-CWP-In-SWRAD arrays if diagnostics requested: SWRAD2B.343
IF (CWPAJON) THEN SWRAD2B.344
DO JJ=1, NCLDS SWRAD2B.345
DO II=1, NDO SWRAD2B.346
CWPAJ(II,JJ)=0.0 SWRAD2B.347
END DO SWRAD2B.348
END DO SWRAD2B.349
END IF SWRAD2B.350
SWRAD2B.351
END IF SWRAD2B.352
SWRAD2B.353
CL SWRAD2B.354
CL ! Section 1 - invert and gather input data for SWMAST SWRAD2B.355
CL ~~~~~~~~~ SWRAD2B.356
CL ! As & Bs of course only need inverting: SWRAD2B.357
Cfpp$ NoConcur L SWRAD2B.358
DO 11 LEVEL=1, NLEVS+1 SWRAD2B.359
ABGI(LEVEL) = ABIN(NLEVS+2-LEVEL) SWRAD2B.360
BBGI(LEVEL) = BBIN(NLEVS+2-LEVEL) SWRAD2B.361
11 CONTINUE SWRAD2B.362
NCLEAR = NLEVS - NCLDS SWRAD2B.363
C SWRAD2B.364
CL ! &, if LCLD3 is on, the first time into the routine, find where SWRAD2B.365
CL ! cloud type boundaries will lie in terms of the numbering of this SWRAD2B.366
CL ! run's eta levels: SWRAD2B.367
C SWRAD2B.368
IF ( LCLD3 .AND. .NOT. SET ) THEN SWRAD2B.369
RANGE(1,1) = 1 SWRAD2B.370
LEVEL = NCLEAR + 1 SWRAD2B.371
DO J=1, 2 SWRAD2B.372
101 ETA = BBGI(LEVEL) + ABGI(LEVEL) / PREF SWRAD2B.373
IF ( ETA .LT. BOUNDS(J) ) THEN SWRAD2B.374
LEVEL = LEVEL + 1 SWRAD2B.375
ETALST = ETA SWRAD2B.376
C ! This assumes the vertical resolution is not too crude in SWRAD2B.377
C ! the troposphere - but it would have to be rather worse SWRAD2B.378
C ! even than the old 11-layer Cyber climate model. SWRAD2B.379
GO TO 101 SWRAD2B.380
ELSE SWRAD2B.381
C ! This has found the first layer boundary below BOUNDS - SWRAD2B.382
C ! is this or the previous one closer ? SWRAD2B.383
IF ( BOUNDS(J)-ETALST .LT. ETA-BOUNDS(J) ) LEVEL = LEVEL-1 SWRAD2B.384
RANGE(J+1,1) = LEVEL - NCLEAR SWRAD2B.385
RANGE(J,2) = RANGE(J+1,1) - 1 SWRAD2B.386
ENDIF SWRAD2B.387
ENDDO SWRAD2B.388
RANGE(3,2) = NCLDS SWRAD2B.389
SET = .TRUE. SWRAD2B.390
ENDIF SWRAD2B.391
C SWRAD2B.392
C SWRAD2B.393
CL ! while single-level or no-level data would just need gathering SWRAD2B.394
C ! - except that convective cloud rE must be calculated from the SWRAD2B.395
C ! temperature of the highest layer the cloud extends into, and SWRAD2B.396
C ! convective cloud base and top must be altered to count from the SWRAD2B.397
C ! top down and to refer to layer centres rather than layer SWRAD2B.398
C ! boundaries, and constrained to have a valid value (where CCA=0, SWRAD2B.399
! P27 does not set CCB or CCT.) MAXCLD is used as temporary SWRAD2B.400
! storage for the gathered temperature input to ROCWWIP (also SWRAD2B.401
! used later by the microphsyics option), and CRE for the output. SWRAD2B.402
DO J=1, NLIT SWRAD2B.403
PSTGI(J) = PSTIN(LIST(J)) SWRAD2B.404
CCAGI(J) = CCAIN(LIST(J)) SWRAD2B.405
CCWPGI(J)= CCWPIN(LIST(J)) SWRAD2B.406
C ! Conversion of CCWP here omitted for the time being. SWRAD2B.407
COSZGI(J)= COSZIN(LIST(J)) SWRAD2B.408
IF ( COSZGI(J) .LT. COSMIN ) COSZGI(J) = COSMIN SWRAD2B.409
CCTGI(J) = NLEVS+2 - CCTIN(LIST(J)) SWRAD2B.410
IF ( CCTGI(J) .GT. NLEVS .OR. CCTGI(J) .LE. NCLEAR ) SWRAD2B.411
& CCTGI(J) = NCLEAR + 1 SWRAD2B.412
CCBGI(J) = NLEVS+1 - CCBIN(LIST(J)) SWRAD2B.413
IF ( CCBGI(J) .GT. NLEVS .OR. CCBGI(J) .LE. NCLEAR ) SWRAD2B.414
& CCBGI(J) = NLEVS SWRAD2B.415
C ! CCTGI (where it was defined) was indexed similarly to TAC, but SWRAD2B.416
C ! we would have to subtract 1 to get the temperature at the SWRAD2B.417
C ! layer centre BELOW the layer boundary indicated by CCT. To SWRAD2B.418
C ! be sure we do not access outside the valid range, we must SWRAD2B.419
C ! actually use CCTGI, which makes it a little less clear. SWRAD2B.420
MAXCLD(J) = TAC(LIST(J),NLEVS+1-CCTGI(J)) SWRAD2B.421
END DO SWRAD2B.422
CALL LSP_FOCWWIL (MAXCLD, NLIT, CRE) SWRAD2B.423
DO J=1, NLIT SWRAD2B.424
TFOC = MAXCLD(J) SWRAD2B.425
FOCWWIL = CRE(J) SWRAD2B.426
IF (MICRO) THEN SWRAD2B.427
SWRAD2B.428
IF (LAND(LIST(J))) THEN SWRAD2B.429
DCONRE = DCONRE_LAND ! Continental clouds. SWRAD2B.430
KPARAM = KPARAM_LAND SWRAD2B.431
NTOT = NTOT_LAND SWRAD2B.432
ELSE SWRAD2B.433
DCONRE = DCONRE_SEA ! Maritime clouds. SWRAD2B.434
KPARAM = KPARAM_SEA SWRAD2B.435
NTOT = NTOT_SEA SWRAD2B.436
END IF SWRAD2B.437
IF (CCAGI(J).LE.0.0) THEN SWRAD2B.438
CRE(J)=0.0 ! Set rE to zero for no cloud. SWRAD2B.439
ELSE SWRAD2B.440
PCCTOP=ABIN(CCTIN(LIST(J)))+BBIN(CCTIN(LIST(J)))*PSTGI(J) SWRAD2B.441
PCCBOT=ABIN(CCBIN(LIST(J)))+BBIN(CCBIN(LIST(J)))*PSTGI(J) SWRAD2B.442
DELTAZ=(R*TFOC/G)*ALOG(PCCBOT/PCCTOP) SWRAD2B.443
IF (DELTAZ .LT. 500.0) THEN ! Shallow convection. SWRAD2B.444
LWC=(CCWPGI(J)/DELTAZ) SWRAD2B.445
SCONRE=(3.0*LWC/(4.0*PI*RHO_WATER*KPARAM*NTOT))**(1.0/3.0) SWRAD2B.446
CRE(J)=REICE+(SCONRE-REICE)*FOCWWIL SWRAD2B.447
C Set safe rE limits (for SWCLOP): SWRAD2B.448
IF (CRE(J).LT.0.35E-06) CRE(J)=0.35E-06 SWRAD2B.449
IF (CRE(J).GT.37.0E-06) CRE(J)=37.0E-06 SWRAD2B.450
ELSE SWRAD2B.451
CRE(J)=REICE+(DCONRE-REICE)*FOCWWIL ! Deep convection. SWRAD2B.452
END IF SWRAD2B.453
END IF SWRAD2B.454
IF (CREFFO) CREFF(LIST(J))=CRE(J) * CCAGI(J) * 1000000.0 SWRAD2B.455
IF (CVAMTO) CVAMT(LIST(J))=CCAGI(J) * 1000000.0 SWRAD2B.456
SWRAD2B.457
ELSE SWRAD2B.458
SWRAD2B.459
CRE(J) = REICE + DRE * FOCWWIL SWRAD2B.460
SWRAD2B.461
END IF SWRAD2B.462
SWRAD2B.463
ENDDO SWRAD2B.464
C SWRAD2B.465
CL ! Water is gathered and inverted at NWET levels: SWRAD2B.466
DO 14 LEVEL=1, NWET SWRAD2B.467
Cfpp$ Select(CONCUR) SWRAD2B.468
DO 14 J=1, NLIT SWRAD2B.469
H2OGI(J,LEVEL) = H2OIN(LIST(J),NWET+1-LEVEL) SWRAD2B.470
14 CONTINUE SWRAD2B.471
C SWRAD2B.472
CL ! and ozone at NOZONE... SWRAD2B.473
DO 15 LEVEL=1, NOZONE SWRAD2B.474
Cfpp$ Select(CONCUR) SWRAD2B.475
DO 15 J=1, NLIT SWRAD2B.476
O3GI(J,LEVEL) = O3IN(LIST(J),NOZONE+1-LEVEL) SWRAD2B.477
15 CONTINUE SWRAD2B.478
C SWRAD2B.479
CL ! Layer cloud data are gathered and inverted at NCLDS levels. SWRAD2B.480
C ! rE is calculated as for convective cloud, SWRAD2B.481
C ! and also QL & QF are added together. SWRAD2B.482
DO 16 LEVEL=1, NCLDS SWRAD2B.483
DACON2 = ( ABIN(NCLDS+1-LEVEL) - ABIN(NCLDS+2-LEVEL) ) / G SWRAD2B.484
DBCON2 = ( BBIN(NCLDS+1-LEVEL) - BBIN(NCLDS+2-LEVEL) ) / G SWRAD2B.485
Cfpp$ Select(CONCUR) SWRAD2B.486
DO J=1, NLIT SWRAD2B.487
LCAGI(J,LEVEL) = LCAIN(LIST(J),NCLDS+1-LEVEL) SWRAD2B.488
MAXCLD(J) = TAC(LIST(J),NCLDS+1-LEVEL) SWRAD2B.489
END DO SWRAD2B.490
IF (L_CLOUD_WATER_PARTITION) THEN AYY1F404.300
! calculate proportion of liquid water focwwil as ratio qcl/(qcl+qcf) AYY1F404.301
DO J=1, NLIT AYY1F404.302
IF (LCAGI(J,LEVEL) .GT. 0.) THEN AYY1F404.303
LRE(J,LEVEL) = LCW1IN(LIST(J),NCLDS+1-LEVEL) / AYY1F404.304
& (LCW1IN(LIST(J),NCLDS+1-LEVEL)+LCW2IN(LIST(J),NCLDS+1-LEVEL)) AYY1F404.305
ELSE AYY1F404.306
! Arbitrary number: makes it safe & vectorizable AYY1F404.307
LRE(J,LEVEL) = 0.0 AYY1F404.308
ENDIF AYY1F404.309
END DO AYY1F404.310
ELSE AYY1F404.311
! set proportion of liquid water focwwil from parametrized function AYY1F404.312
CALL LSP_FOCWWIL (MAXCLD, NLIT, LRE(1,LEVEL)) AYY1F404.313
ENDIF AYY1F404.314
! AYY1F404.315
DO J=1, NLIT SWRAD2B.492
TFOC = MAXCLD(J) SWRAD2B.493
FOCWWIL = LRE(J,LEVEL) SWRAD2B.494
IF (MICRO) THEN SWRAD2B.495
SWRAD2B.496
IF (LAND(LIST(J))) THEN SWRAD2B.497
KPARAM = KPARAM_LAND SWRAD2B.498
NTOT = NTOT_LAND SWRAD2B.499
ELSE SWRAD2B.500
KPARAM = KPARAM_SEA SWRAD2B.501
NTOT = NTOT_SEA SWRAD2B.502
END IF SWRAD2B.503
LCMMR = ( LCW1IN(LIST(J), NCLDS+1-LEVEL) SWRAD2B.504
& + LCW2IN(LIST(J), NCLDS+1-LEVEL) ) SWRAD2B.505
IF (LCAGI(J,LEVEL) .GT. 0.0) THEN SWRAD2B.506
LCMMR = LCMMR / LCAGI(J,LEVEL) SWRAD2B.507
PRESS1=ABIN(NCLDS+1-LEVEL)+BBIN(NCLDS+1-LEVEL)*PSTGI(J) SWRAD2B.508
PRESS2=ABIN(NCLDS+2-LEVEL)+BBIN(NCLDS+2-LEVEL)*PSTGI(J) SWRAD2B.509
RHOAIR=(EXP((ALOG(PRESS1)+ALOG(PRESS2))/2.0)) / (R*TFOC) SWRAD2B.510
LWC=LCMMR * RHOAIR SWRAD2B.511
IF (LEVEL .GE. RANGE(3,1)) THEN ! Low cloud SWRAD2B.512
LAYERE(J,LEVEL)=(6.0*LWC/(4.0*PI*RHO_WATER*KPARAM*NTOT)) SWRAD2B.513
& **(1.0/3.0) SWRAD2B.514
ELSE SWRAD2B.515
LAYERE(J,LEVEL)=(3.0*LWC/(4.0*PI*RHO_WATER*KPARAM*NTOT)) SWRAD2B.516
& **(1.0/3.0) SWRAD2B.517
END IF SWRAD2B.518
LRE(J,LEVEL)=REICE+(LAYERE(J,LEVEL)-REICE)*FOCWWIL SWRAD2B.519
C Set safe rE limits (for SWCLOP): SWRAD2B.520
IF (LRE(J,LEVEL).LT.0.35E-06) LRE(J,LEVEL)=0.35E-06 SWRAD2B.521
IF (LRE(J,LEVEL).GT.37.0E-06) LRE(J,LEVEL)=37.0E-06 SWRAD2B.522
ELSE SWRAD2B.523
LRE(J,LEVEL)=0.0 SWRAD2B.524
LAYERE(J,LEVEL)=0.0 SWRAD2B.525
END IF SWRAD2B.526
SWRAD2B.527
ELSE SWRAD2B.528
SWRAD2B.529
LRE(J,LEVEL) = REICE + DRE * FOCWWIL SWRAD2B.530
SWRAD2B.531
END IF SWRAD2B.532
SWRAD2B.533
LCWPGI(J,LEVEL) = ( DACON2 + DBCON2 * PSTGI(J) ) * SWRAD2B.534
& ( LCW1IN(LIST(J),NCLDS+1-LEVEL) + LCW2IN(LIST(J),NCLDS+1-LEVEL) ) SWRAD2B.535
IF ( ( .NOT. LCLD3 ) .AND. LCAGI(J,LEVEL) .GT. 0. ) SWRAD2B.536
& LCWPGI(J,LEVEL)= LCWPGI(J,LEVEL) / LCAGI(J,LEVEL) SWRAD2B.537
END DO SWRAD2B.538
16 CONTINUE SWRAD2B.539
CL ! If the option to combine layer clouds into 3 layers is on, do so SWRAD2B.540
IF ( LCLD3 ) THEN SWRAD2B.541
C SWRAD2B.542
CL ! Now, find which layer holds most cloud of each "type": SWRAD2B.543
C ! (The loops over TYPE, and over LEVEL inside them, are from the SWRAD2B.544
C ! top down, as usual for loops involving TYPE or ..GI arrays.) SWRAD2B.545
C SWRAD2B.546
DO TYPE=1, 3 SWRAD2B.547
Cfpp$ Select(CONCUR) SWRAD2B.548
DO J=1, NLIT SWRAD2B.549
TOTCWC(J) = LCWPGI(J,RANGE(TYPE,1)) SWRAD2B.550
MAXCLD(J) = LCAGI(J,RANGE(TYPE,1)) SWRAD2B.551
INDEX(J) = RANGE(TYPE,1) SWRAD2B.552
ENDDO SWRAD2B.553
DO LEVEL=RANGE(TYPE,1)+1, RANGE(TYPE,2) SWRAD2B.554
Cfpp$ Select(CONCUR) SWRAD2B.555
DO 161 J=1, NLIT SWRAD2B.556
TOTCWC(J) = TOTCWC(J) + LCWPGI(J,LEVEL) SWRAD2B.557
IF ( MAXCLD(J) .LT. LCAGI(J,LEVEL) ) THEN SWRAD2B.558
MAXCLD(J) = LCAGI(J,LEVEL) SWRAD2B.559
INDEX(J) = LEVEL SWRAD2B.560
ENDIF SWRAD2B.561
161 CONTINUE ! Next J SWRAD2B.562
ENDDO ! Next LEVEL SWRAD2B.563
C SWRAD2B.564
CL ! and use it to set the values in the array passed to SWMAST: SWRAD2B.565
C SWRAD2B.566
C ! We have the level of maximum cover for each type in the input SWRAD2B.567
C ! data, which will be the only one left non-zero. Its CWC is SWRAD2B.568
C ! set to the sum of the CWC in all the levels of that "type" SWRAD2B.569
C ! (this sum being done on the grid-box means, which will then SWRAD2B.570
C ! be converted to an in-cloud value using the selected SWRAD2B.571
C ! (maximum) cloud amount). The other levels' CWC and the rE SWRAD2B.572
C ! are not altered. SWRAD2B.573
DO LEVEL=RANGE(TYPE,1), RANGE(TYPE,2) SWRAD2B.574
Cfpp$ Select(CONCUR) SWRAD2B.575
DO 162 J=1, NLIT SWRAD2B.576
IF ( LEVEL .EQ. INDEX(J) ) THEN SWRAD2B.577
IF ( LCAGI(J,LEVEL) .GT. 0. ) SWRAD2B.578
& TOTCWC(J) = TOTCWC(J) / LCAGI(J,LEVEL) SWRAD2B.579
LCWPGI(J,LEVEL) = TOTCWC(J) SWRAD2B.580
IF (MICRO) CWPAJGI(J,LEVEL) = LCWPGI(J,LEVEL) SWRAD2B.581
ELSE SWRAD2B.582
LCAGI(J,LEVEL) = 0. SWRAD2B.583
IF (MICRO) CWPAJGI(J,LEVEL) = 0.0 SWRAD2B.584
ENDIF SWRAD2B.585
162 CONTINUE ! Next J SWRAD2B.586
ENDDO ! Next LEVEL SWRAD2B.587
ENDDO ! Next TYPE SWRAD2B.588
C SWRAD2B.589
C ! If wanted repeat the reduction-to-three-cloud-layers, but now SWRAD2B.590
C ! for all points & the other way up, for the diagnostic LCA3L. SWRAD2B.591
C ! This must be done if this diagnostic is wanted in its own right SWRAD2B.592
C ! or if TCASW is, as the latter is calculated from it. SWRAD2B.593
C ! (The loop over TYPE is still from the top down, but the loops SWRAD2B.594
C ! over LEVEL are now from the bottom up, to match how the clouds SWRAD2B.595
C ! are input and the output has to be output.) SWRAD2B.596
C SWRAD2B.597
IF ( LCA3ON .OR. TCASWO ) THEN SWRAD2B.598
DO TYPE=1, 3 SWRAD2B.599
FSTLEV = NCLDS + 1 - RANGE(TYPE,2) SWRAD2B.600
LSTLEV = NCLDS + 1 - RANGE(TYPE,1) SWRAD2B.601
Cfpp$ Select(CONCUR) SWRAD2B.602
DO J=1, NDO SWRAD2B.603
MAXCLD(J) = LCAIN(J,FSTLEV) SWRAD2B.604
INDEX(J) = FSTLEV SWRAD2B.605
ENDDO SWRAD2B.606
DO LEVEL=FSTLEV+1, LSTLEV SWRAD2B.607
Cfpp$ Select(CONCUR) SWRAD2B.608
DO 163 J=1, NDO SWRAD2B.609
IF ( MAXCLD(J) .LT. LCAIN(J,LEVEL) ) THEN SWRAD2B.610
MAXCLD(J) = LCAIN(J,LEVEL) SWRAD2B.611
INDEX(J) = LEVEL SWRAD2B.612
ENDIF SWRAD2B.613
163 CONTINUE ! Next J SWRAD2B.614
ENDDO ! Next LEVEL SWRAD2B.615
DO LEVEL=FSTLEV, LSTLEV SWRAD2B.616
Cfpp$ Select(CONCUR) SWRAD2B.617
DO 164 J=1, NDO SWRAD2B.618
IF ( LEVEL .EQ. INDEX(J) ) THEN SWRAD2B.619
LCA3L(J,LEVEL) = MAXCLD(J) SWRAD2B.620
ELSE SWRAD2B.621
LCA3L(J,LEVEL) = 0. SWRAD2B.622
ENDIF SWRAD2B.623
164 CONTINUE ! Next J SWRAD2B.624
ENDDO ! Next LEVEL SWRAD2B.625
ENDDO ! Next TYPE SWRAD2B.626
END IF SWRAD2B.627
ENDIF ! LCLD3 SWRAD2B.628
C SWRAD2B.629
IF (MICRO) THEN SWRAD2B.630
SWRAD2B.631
DO II=1,NCLDS SWRAD2B.632
DO JJ=1,NLIT SWRAD2B.633
L1AJ=LCAGI(JJ,II) SWRAD2B.634
IF (L1AJ .GT. 0.0) THEN SWRAD2B.635
TAU=(1.5*CWPAJGI(JJ,II)/(1000.0*LRE(JJ,II)))*L1AJ SWRAD2B.636
ELSE SWRAD2B.637
TAU=0.0 SWRAD2B.638
END IF SWRAD2B.639
IF (TAU .LT. 5.0) L1AJ = 0.0 SWRAD2B.640
IF (LREFFO) THEN SWRAD2B.641
LREFF(LIST(JJ),NCLDS+1-II) = LAYERE(JJ,II)*L1AJ*1.0E06 SWRAD2B.642
END IF SWRAD2B.643
IF (LRAMTO) THEN SWRAD2B.644
LRAMT(LIST(JJ),NCLDS+1-II) = L1AJ * 1.0E06 SWRAD2B.645
END IF SWRAD2B.646
IF (CWPAJON) THEN SWRAD2B.647
CWPAJ(LIST(JJ),NCLDS+1-II) = CWPAJGI(JJ,II) * L1AJ SWRAD2B.648
END IF SWRAD2B.649
ENDDO SWRAD2B.650
ENDDO SWRAD2B.651
SWRAD2B.652
END IF SWRAD2B.653
C SWRAD2B.654
CL ! Gathering the clear-sky surface albedos, multiple copies are SWRAD2B.655
CL ! needed as P234 code expects band-dependent ones, which P233 SWRAD2B.656
CL ! does not yet produce. SWRAD2B.657
DO 171 DIRDIF=1, 2 SWRAD2B.658
Cfpp$ Select(CONCUR) SWRAD2B.659
DO 17 J=1, NLIT SWRAD2B.660
SAOSGI(J,1,DIRDIF) = SAOSIN(LIST(J),DIRDIF) SWRAD2B.661
SAGI (J,1,DIRDIF) = SALIIN(LIST(J),MIN(DIRDIF,NLALBS)) AWI1F403.409
IF ( .NOT. LAND(LIST(J)) ) SWRAD2B.663
& SAGI(J,1,DIRDIF) = SAGI(J,1,DIRDIF) * AICE(LIST(J)) + SWRAD2B.664
& SAOSGI(J,1,DIRDIF) * ( 1.-AICE(LIST(J)) ) SWRAD2B.665
17 CONTINUE SWRAD2B.667
IF ( SO4_FORCE_ON ) THEN AWI1F403.410
DO J=1, NLIT AWI1F403.411
SANAGI(J,1,DIRDIF) = SANAIN(LIST(J),DIRDIF) AWI1F403.412
ENDDO AWI1F403.413
DO BAND=2, NBANDS AWI1F403.414
DO J=1, NLIT AWI1F403.415
SANAGI(J,BAND,DIRDIF) = SANAGI(J,1,DIRDIF) AWI1F403.416
ENDDO AWI1F403.417
ENDDO AWI1F403.418
ENDIF AWI1F403.419
DO 171 BAND=2, NBANDS SWRAD2B.668
Cfpp$ Select(CONCUR) SWRAD2B.669
DO 171 J=1, NLIT SWRAD2B.670
SAGI(J,BAND,DIRDIF) = SAGI(J,1,DIRDIF) SWRAD2B.671
SAOSGI(J,BAND,DIRDIF) = SAOSGI(J,1,DIRDIF) SWRAD2B.672
171 CONTINUE SWRAD2B.674
C SWRAD2B.675
C ! Diagnose cloud-if-sunlit if wanted: SWRAD2B.676
C SWRAD2B.677
IF ( CCASWO ) THEN SWRAD2B.678
DO J=1, NDO SWRAD2B.679
CCASW(J) = 0.0 SWRAD2B.680
END DO SWRAD2B.681
CDir$ IVDep SWRAD2B.682
Cfpp$ NoConcur L SWRAD2B.683
DO J=1, NLIT SWRAD2B.684
CCASW(LIST(J)) = CCAGI(J) SWRAD2B.685
END DO SWRAD2B.686
END IF SWRAD2B.687
IF ( LCASWO ) THEN SWRAD2B.688
DO LEVEL=1, NCLDS SWRAD2B.689
Cfpp$ Select(Concur) SWRAD2B.690
DO J=1, NDO SWRAD2B.691
LCASW(J,LEVEL) = 0.0 SWRAD2B.692
END DO SWRAD2B.693
CDir$ IVDep SWRAD2B.694
Cfpp$ NoConcur L SWRAD2B.695
DO J=1, NLIT SWRAD2B.696
LCASW(LIST(J),LEVEL) = LCAGI(J,NCLDS+1-LEVEL) SWRAD2B.697
END DO SWRAD2B.698
END DO SWRAD2B.699
END IF SWRAD2B.700
C SWRAD2B.701
CL ! Set NNIGHT, the number of night points to be treated by this SWRAD2B.702
CL ! CALL to SWRAD SWRAD2B.703
NNIGHT=NDO-NLIT SWRAD2B.704
C SWRAD2B.705
CL SWRAD2B.706
CL ! Section 2 - CALL SWMAST SWRAD2B.707
CL ~~~~~~~~~ SWRAD2B.708
CALL SWMAST (H2OGI, CO2, O3GI, PSTGI, ABGI, BBGI, LCAGI, LCWPGI, SWRAD2B.709
& LRE, CCAGI, CCWPGI, CRE, CCBGI, CCTGI, COSZGI, SWRAD2B.710
& SAGI, SAOSGI, LUT, SWRAD2B.711
& CSOSDI(1+NNIGHT), CSOSON, NSSB1(1+NNIGHT), NSS1ON, SWRAD2B.712
& TDSS(1+NNIGHT), TDSSON, SWRAD2B.713
& CSSSD(1+NNIGHT), CSSSDO, CSSSU(1+NNIGHT), CSSSUO, SWRAD2B.714
& LCAAR(1+NNIGHT,1), LCAARO, LCAARL, LCAARB, SWRAD2B.715
& LCAAF(1+NNIGHT,1), LCAAFO, LCAAFL, LCAAFB, SWRAD2B.716
& CCAAR(1+NNIGHT,1), CCAARO, CCAARB, SWRAD2B.717
& CCAAF(1+NNIGHT,1), CCAAFO, CCAAFB, SWRAD2B.718
& NLIT, NLEVS, NCLDS, SWRAD2B.719
& SO4_FORCE(1+NNIGHT), SO4_FORCE_ON, SANAGI, NAADIM, AWI1F403.420
& NWET, NOZONE, NLIT, L1, SWSEA(1+NNIGHT), SWOUT(1+NNIGHT,1) ) SWRAD2B.721
C SWRAD2B.722
C SWRAD2B.723
CL ! Also, zero areas of SWOUT & SWSEA that will not be set by SWMAST SWRAD2B.724
C SWRAD2B.725
C ! (They are multiplied, here or in the control routines, SWRAD2B.726
C ! by the mean cosz for each physics timestep, i.e. zero at night SWRAD2B.727
C ! points, but this would fail if a word were not a valid real.) SWRAD2B.728
C ! SWRAD2B.729
IF ( NDO.GT.NLIT ) THEN SWRAD2B.730
DO 20 LEVEL=1, NLEVS+2 SWRAD2B.731
Cfpp$ Select(CONCUR) SWRAD2B.732
DO 20 J=1, NNIGHT SWRAD2B.733
SWOUT(J,LEVEL) = 0. SWRAD2B.734
20 CONTINUE SWRAD2B.735
DO J=1, NNIGHT SWRAD2B.736
SWSEA(J) = 0. SWRAD2B.737
ENDDO SWRAD2B.738
ENDIF SWRAD2B.739
C SWRAD2B.740
C SWRAD2B.741
CL ! Section 3 - convert normalized net downward flux to atmospheric SWRAD2B.742
CL ! ~~~~~~~~~ heating rates and surface actual net downward flux SWRAD2B.743
C SWRAD2B.744
CL ! Set up normalized-to-actual flux conversion factors: SWRAD2B.745
CL ! the incoming insolation at the top of the atmosphere SWRAD2B.746
C SWRAD2B.747
NSI = SC * SCS SWRAD2B.748
DO 31 J=1, NDO SWRAD2B.749
IITOA(J) = NSI * COSZIN(J) * LIT(J) SWRAD2B.750
31 CONTINUE SWRAD2B.751
C SWRAD2B.752
CL ! and set COSZGI to the same for daylit points SWRAD2B.753
C SWRAD2B.754
DO 32 J=1, NLIT SWRAD2B.755
COSZGI(J) = IITOA(LIST(J)) SWRAD2B.756
32 CONTINUE SWRAD2B.757
C SWRAD2B.758
CL ! Fill NTSWIN: SWRAD2B.759
C SWRAD2B.760
DO J=1, NDO SWRAD2B.761
NTSWIN(J) = 0. SWRAD2B.762
ENDDO SWRAD2B.763
C SWRAD2B.764
CDir$ IVDep SWRAD2B.765
Cfpp$ NoConcur L SWRAD2B.766
DO 323 J=1, NLIT SWRAD2B.767
NTSWIN(LIST(J)) = COSZGI(J) * SWOUT(J+NNIGHT,1) SWRAD2B.768
323 CONTINUE SWRAD2B.769
C SWRAD2B.770
C ! Before flux-differencing, diagnose outgoing solar if wanted : SWRAD2B.771
C SWRAD2B.772
IF ( OSON ) THEN SWRAD2B.773
DO J=1, NDO SWRAD2B.774
OSDIA(J) = 0. SWRAD2B.775
ENDDO SWRAD2B.776
CDir$ IVDep SWRAD2B.777
Cfpp$ NoConcur L SWRAD2B.778
DO J=1, NLIT SWRAD2B.779
OSDIA(LIST(J)) = COSZGI(J) * ( 1. - SWOUT(J+NNIGHT,1) ) SWRAD2B.780
ENDDO SWRAD2B.781
ENDIF SWRAD2B.782
CL SWRAD2B.783
CL ! and if CSOSDI is wanted, scatter it back and convert it from SWRAD2B.784
CL ! normalized to actual flux: SWRAD2B.785
CL SWRAD2B.786
IF ( CSOSON ) THEN SWRAD2B.787
DO J=1, NNIGHT SWRAD2B.788
CSOSDI(J) = 0. SWRAD2B.789
ENDDO SWRAD2B.790
CDir$ IVDep SWRAD2B.791
Cfpp$ NoConcur L SWRAD2B.792
DO J=1, NLIT SWRAD2B.793
CSOSDI(LIST(J)) = CSOSDI(J+NNIGHT) SWRAD2B.794
ENDDO SWRAD2B.795
DO J=1, NDO SWRAD2B.796
CSOSDI(J) = IITOA(J) * CSOSDI(J) SWRAD2B.797
ENDDO SWRAD2B.798
ENDIF SWRAD2B.799
C SWRAD2B.800
IF ( SO4_FORCE_ON ) THEN SWRAD2B.801
DO J=1, NNIGHT SWRAD2B.802
SO4_FORCE(J) = 0. SWRAD2B.803
ENDDO SWRAD2B.804
DO J=1, NLIT SWRAD2B.805
SO4_FORCE(LIST(J)) = SO4_FORCE(J+NNIGHT) SWRAD2B.806
ENDDO SWRAD2B.807
DO J=1, NDO SWRAD2B.808
SO4_FORCE(J) = IITOA(J) * SO4_FORCE(J) SWRAD2B.809
ENDDO SWRAD2B.810
ENDIF SWRAD2B.811
SWRAD2B.812
CL ! Scatter NSSB1 back and convert from normalized to actual flux SWRAD2B.813
C ! (including multiplication by open-sea fraction), and set to SWRAD2B.814
C ! zero over land: SWRAD2B.815
C SWRAD2B.816
IF( NSS1ON) THEN SWRAD2B.817
DO J=1, NNIGHT SWRAD2B.818
NSSB1(J) = 0. SWRAD2B.819
ENDDO SWRAD2B.820
CDir$ IVDep SWRAD2B.821
Cfpp$ NoConcur L SWRAD2B.822
DO J=1, NLIT SWRAD2B.823
NSSB1(LIST(J)) = NSSB1(J+NNIGHT) SWRAD2B.824
ENDDO SWRAD2B.825
C Set NSSB1 over both land and sea surface SWRAD2B.826
DO J=1, NDO SWRAD2B.827
IF ( LAND(J) ) THEN SWRAD2B.828
NSSB1(J) = IITOA(J) * NSSB1(J) SWRAD2B.829
ELSE SWRAD2B.830
NSSB1(J) = IITOA(J) * ( 1. - AICE(J) ) * NSSB1(J) SWRAD2B.831
ENDIF SWRAD2B.832
ENDDO ! NDO SWRAD2B.842
SWRAD2B.843
ELSE ! NSS1ON is false SWRAD2B.844
C Photosynthetically active radiation not required, but initialise to SWRAD2B.845
C zero to avoid possible problems accessing uninitialised data later. SWRAD2B.846
DO J=1,NDO SWRAD2B.847
SWOUT(J,NLEVS+2) = 0.0 SWRAD2B.848
ENDDO ! NDO SWRAD2B.849
SWRAD2B.850
ENDIF ! NSS1ON SWRAD2B.851
C SWRAD2B.852
CL ! Scatter TDSS back and convert from normalized to actual flux: SWRAD2B.853
C SWRAD2B.854
IF ( TDSSON ) THEN SWRAD2B.855
DO J=1, NNIGHT SWRAD2B.856
TDSS(J) = 0. SWRAD2B.857
ENDDO SWRAD2B.858
CDir$ IVDep SWRAD2B.859
Cfpp$ NoConcur L SWRAD2B.860
DO J=1, NLIT SWRAD2B.861
TDSS(LIST(J)) = TDSS(J+NNIGHT) SWRAD2B.862
ENDDO SWRAD2B.863
DO J=1, NDO SWRAD2B.864
TDSS(J) = IITOA(J) * TDSS(J) SWRAD2B.865
ENDDO SWRAD2B.866
ENDIF SWRAD2B.867
C SWRAD2B.868
CL ! And the same for CSSSD and CSSSU: SWRAD2B.869
C SWRAD2B.870
IF ( CSSSDO ) THEN SWRAD2B.871
DO J=1, NNIGHT SWRAD2B.872
CSSSD(J) = 0. SWRAD2B.873
ENDDO SWRAD2B.874
CDir$ IVDep SWRAD2B.875
Cfpp$ NoConcur L SWRAD2B.876
DO J=1, NLIT SWRAD2B.877
CSSSD(LIST(J)) = CSSSD(J+NNIGHT) SWRAD2B.878
ENDDO SWRAD2B.879
DO J=1, NDO SWRAD2B.880
CSSSD(J) = IITOA(J) * CSSSD(J) SWRAD2B.881
ENDDO SWRAD2B.882
ENDIF SWRAD2B.883
IF ( CSSSUO ) THEN SWRAD2B.884
DO J=1, NNIGHT SWRAD2B.885
CSSSU(J) = 0. SWRAD2B.886
ENDDO SWRAD2B.887
CDir$ IVDep SWRAD2B.888
Cfpp$ NoConcur L SWRAD2B.889
DO J=1, NLIT SWRAD2B.890
CSSSU(LIST(J)) = CSSSU(J+NNIGHT) SWRAD2B.891
ENDDO SWRAD2B.892
DO J=1, NDO SWRAD2B.893
CSSSU(J) = IITOA(J) * CSSSU(J) SWRAD2B.894
ENDDO SWRAD2B.895
ENDIF SWRAD2B.896
C SWRAD2B.897
CL ! and cloud albedo diagnostics: SWRAD2B.898
C SWRAD2B.899
IF ( LCAARO ) THEN SWRAD2B.900
OFFSET = 1 SWRAD2B.901
DO 338 BAND=1, NBANDS SWRAD2B.902
DO 338 LEVEL=1, NCLDS SWRAD2B.903
IF ( LCAARL(LEVEL) .AND. LCAARB(BAND) ) THEN SWRAD2B.904
CDir$ IVDep SWRAD2B.905
Cfpp$ NoConcur L SWRAD2B.906
DO J=1, NLIT SWRAD2B.907
LCAAR(LIST(J),OFFSET) = LCAAR(J+NNIGHT,OFFSET) SWRAD2B.908
ENDDO SWRAD2B.909
CDir$ IVDep SWRAD2B.910
DO J=1, NDO SWRAD2B.911
IF ( LIT(J) .EQ. 0. ) LCAAR(J,OFFSET) = 0. SWRAD2B.912
ENDDO SWRAD2B.913
OFFSET = OFFSET + 1 SWRAD2B.914
ENDIF SWRAD2B.915
338 CONTINUE SWRAD2B.916
ENDIF SWRAD2B.917
IF ( LCAAFO ) THEN SWRAD2B.918
OFFSET = 1 SWRAD2B.919
DO 337 BAND=1, NBANDS SWRAD2B.920
DO 337 LEVEL=1, NCLDS SWRAD2B.921
IF ( LCAAFL(LEVEL) .AND. LCAAFB(BAND) ) THEN SWRAD2B.922
CDir$ IVDep SWRAD2B.923
Cfpp$ NoConcur L SWRAD2B.924
DO J=1, NLIT SWRAD2B.925
LCAAF(LIST(J),OFFSET) = LCAAF(J+NNIGHT,OFFSET) SWRAD2B.926
ENDDO SWRAD2B.927
CDir$ IVDep SWRAD2B.928
DO J=1, NDO SWRAD2B.929
IF ( LIT(J) .EQ. 0. ) LCAAF(J,OFFSET) = 0. SWRAD2B.930
ENDDO SWRAD2B.931
OFFSET = OFFSET + 1 SWRAD2B.932
ENDIF SWRAD2B.933
337 CONTINUE SWRAD2B.934
ENDIF SWRAD2B.935
IF ( CCAARO ) THEN SWRAD2B.936
OFFSET = 1 SWRAD2B.937
DO 336 BAND=1, NBANDS SWRAD2B.938
IF ( CCAARB(BAND) ) THEN SWRAD2B.939
CDir$ IVDep SWRAD2B.940
Cfpp$ NoConcur L SWRAD2B.941
DO J=1, NLIT SWRAD2B.942
CCAAR(LIST(J),OFFSET) = CCAAR(J+NNIGHT,OFFSET) SWRAD2B.943
ENDDO SWRAD2B.944
CDir$ IVDep SWRAD2B.945
DO J=1, NDO SWRAD2B.946
IF ( LIT(J) .EQ. 0. ) CCAAR(J,OFFSET) = 0. SWRAD2B.947
ENDDO SWRAD2B.948
OFFSET = OFFSET + 1 SWRAD2B.949
ENDIF SWRAD2B.950
336 CONTINUE SWRAD2B.951
ENDIF SWRAD2B.952
IF ( CCAAFO ) THEN SWRAD2B.953
OFFSET = 1 SWRAD2B.954
DO 335 BAND=1, NBANDS SWRAD2B.955
IF ( CCAAFB(BAND) ) THEN SWRAD2B.956
CDir$ IVDep SWRAD2B.957
Cfpp$ NoConcur L SWRAD2B.958
DO J=1, NLIT SWRAD2B.959
CCAAF(LIST(J),OFFSET) = CCAAF(J+NNIGHT,OFFSET) SWRAD2B.960
ENDDO SWRAD2B.961
CDir$ IVDep SWRAD2B.962
DO J=1, NDO SWRAD2B.963
IF ( LIT(J) .EQ. 0. ) CCAAF(J,OFFSET) = 0. SWRAD2B.964
ENDDO SWRAD2B.965
OFFSET = OFFSET + 1 SWRAD2B.966
ENDIF SWRAD2B.967
335 CONTINUE SWRAD2B.968
ENDIF SWRAD2B.969
C SWRAD2B.970
CL ! Invert SWOUT and scatter it and SWSEA back SWRAD2B.971
C SWRAD2B.972
CDir$ IVDep SWRAD2B.973
Cfpp$ NoConcur L SWRAD2B.974
DO 33 J=1, NLIT SWRAD2B.975
SWSEA(LIST(J)) = SWSEA(J+NNIGHT) SWRAD2B.976
33 CONTINUE SWRAD2B.977
NLP1B2=(NLEVS+1)/2 SWRAD2B.978
CIf this were NLEVS/2+1, could omit special case (do (twice) as general) SWRAD2B.979
DO 34 LEVEL=1, NLP1B2 SWRAD2B.980
CDir$ IVDep SWRAD2B.981
Cfpp$ NoConcur L SWRAD2B.982
DO 34 J=1, NLIT SWRAD2B.983
TEMPOR = SWOUT(J+NNIGHT,LEVEL) SWRAD2B.984
SWOUT(LIST(J),LEVEL) = SWOUT(J+NNIGHT,NLEVS+2-LEVEL) SWRAD2B.985
SWOUT(LIST(J),NLEVS+2-LEVEL) = TEMPOR SWRAD2B.986
34 CONTINUE SWRAD2B.987
IF ( NLEVS/2*2 .EQ. NLEVS ) THEN ! Middle level: scatter only SWRAD2B.988
CDir$ IVDep SWRAD2B.989
Cfpp$ NoConcur L SWRAD2B.990
DO 35 J=1, NLIT SWRAD2B.991
SWOUT(LIST(J),LEVEL) = SWOUT(J+NNIGHT,LEVEL) SWRAD2B.992
35 CONTINUE SWRAD2B.993
ENDIF SWRAD2B.994
C SWRAD2B.995
CL ! If wanted, diagnose total cloud amount as seen by the SW: SWRAD2B.996
C SWRAD2B.997
IF ( TCASWO ) THEN SWRAD2B.998
IF ( LCLD3 ) THEN SWRAD2B.999
CALL SWDTCA (LCA3L, CCAIN, NCLDS, L1, NDO, TCASW) SWRAD2B.1000
ELSE SWRAD2B.1001
CALL SWDTCA (LCAIN, CCAIN, NCLDS, L1, NDO, TCASW) SWRAD2B.1002
ENDIF SWRAD2B.1003
ENDIF SWRAD2B.1004
C SWRAD2B.1005
CL ! Convert fluxes to increments (Eq 1.1), and also put NSI in SWRAD2B.1006
C ! - but omit cosz term (we could multiply by IITOA to get values SWRAD2B.1007
C ! averaged over the whole SW timestep, but this is omitted so SWRAD2B.1008
C ! that the control code can multiply by the correct mean cosz SWRAD2B.1009
C ! for each physics timestep). Also zero the heating rates for SWRAD2B.1010
C ! night points in the later part of the scattered-back vector SWRAD2B.1011
C ! - these should be multiplied by cosz=0 before being added in, SWRAD2B.1012
C ! but there is the possibility of rounding-error-sized cosz SWRAD2B.1013
C ! (from when the sun sets just as the timestep starts, or rises SWRAD2B.1014
C ! just as it finishes) not being calculated consistently on some SWRAD2B.1015
C ! machines, so it is safest to zero them in case, rather than SWRAD2B.1016
C ! leave in the values for some day point which would then be SWRAD2B.1017
C ! added in multiplied by a (very small) cosz to give (very SWRAD2B.1018
C ! small) spurious and batching-dependent heating. SWRAD2B.1019
C SWRAD2B.1020
DO 37 LEVEL=NLEVS, 1, -1 SWRAD2B.1021
DACON1 = ( ABIN(LEVEL) - ABIN(LEVEL+1) ) * CPBYG / ( PTS * NSI ) SWRAD2B.1022
DBCON1 = ( BBIN(LEVEL) - BBIN(LEVEL+1) ) * CPBYG / ( PTS * NSI ) SWRAD2B.1023
DO 38 J=1, NDO SWRAD2B.1024
SWOUT(J,LEVEL+1) = ( SWOUT(J,LEVEL+1) - SWOUT(J,LEVEL) ) SWRAD2B.1025
& / ( DACON1 + PSTIN(J) * DBCON1 ) SWRAD2B.1026
38 CONTINUE SWRAD2B.1027
DO J=NNIGHT+1, NDO SWRAD2B.1028
IF ( IITOA(J) .EQ. 0. ) SWOUT(J,LEVEL+1) = 0. SWRAD2B.1029
ENDDO SWRAD2B.1030
37 CONTINUE SWRAD2B.1031
C SWRAD2B.1032
CL ! Finally, subtract the open-sea contribution from the total SWRAD2B.1033
CL ! net downward surface flux to leave the land-and-sea-ice SWRAD2B.1034
CL ! contribution, and convert both from normalized fluxes to SWRAD2B.1035
CL ! dimensioned ones - they did not get multiplied by NSI as the SWRAD2B.1036
CL ! atmospheric heating rates have just been. The term to be used SWRAD2B.1037
CL ! over land or sea-ice is not multiplied by the cos(solar zenith SWRAD2B.1038
CL ! angle) term because this will be done for each physics SWRAD2B.1039
CL ! timestep in the control routines (though again it is set to SWRAD2B.1040
CL ! zero at night points), but SWSEA and NSSB1 are. SWRAD2B.1041
C SWRAD2B.1042
DO 39 J=1, NDO SWRAD2B.1043
IF ( LAND(J) ) THEN SWRAD2B.1044
SWSEA(J) = 0. SWRAD2B.1045
ELSE SWRAD2B.1046
SWSEA(J) = SWSEA(J) * ( 1.-AICE(J) ) SWRAD2B.1047
SWOUT(J,1) = SWOUT(J,1) - SWSEA(J) SWRAD2B.1048
SWSEA(J) = IITOA(J) * SWSEA(J) SWRAD2B.1049
ENDIF SWRAD2B.1050
SWOUT(J,1) = SWOUT(J,1) * NSI SWRAD2B.1051
39 CONTINUE SWRAD2B.1052
DO J=NNIGHT+1, NDO SWRAD2B.1053
IF ( IITOA(J) .EQ. 0. ) SWOUT(J,1) = 0. SWRAD2B.1054
ENDDO SWRAD2B.1055
C SWRAD2B.1056
RETURN SWRAD2B.1057
END SWRAD2B.1058
*ENDIF DEF,A01_2B SWRAD2B.1059