*IF DEF,A01_1A,OR,DEF,A01_1B,OR,DEF,A01_2A SWRAD1A.2
C ******************************COPYRIGHT****************************** GTS2F400.10045
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10046
C GTS2F400.10047
C Use, duplication or disclosure of this code is subject to the GTS2F400.10048
C restrictions as set forth in the contract. GTS2F400.10049
C GTS2F400.10050
C Meteorological Office GTS2F400.10051
C London Road GTS2F400.10052
C BRACKNELL GTS2F400.10053
C Berkshire UK GTS2F400.10054
C RG12 2SZ GTS2F400.10055
C GTS2F400.10056
C If no contract has been raised with this copy of the code, the use, GTS2F400.10057
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10058
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10059
C Modelling at the above address. GTS2F400.10060
C ******************************COPYRIGHT****************************** GTS2F400.10061
C GTS2F400.10062
CLL Subroutine SWRAD -------------------------------------------------- WI200893.14
CLL SWRAD1A.4
CLL Its main function is to gather the input data for daylit points and SWRAD1A.5
CLL pass them to SWMAST, the top-level routine for P234, the SWRAD1A.6
CLL plug-compatible interaction of shortwave radiation with the SWRAD1A.7
CLL atmosphere, and to scatter the output back. It may return fluxes SWRAD1A.8
CLL at all layer boundaries, or heating rates produced by differencing SWRAD1A.9
CLL the fluxes (plus the surface flux); it can also deal with SWRAD1A.10
CLL shortwave diagnostics. SWRAD1A.11
CLL Before SWRAD is called, SWLKIN (in deck SWTRAN) must be CALLed to SWRAD1A.12
CLL initialize LUT SWRAD1A.13
CLL If *DEF IBM is set, the code is standard FORTRAN 77 except for SWRAD1A.14
CLL having ! comments (it then sets the "vector length" to be 1) but SWRAD1A.15
CLL otherwise it includes CRAY automatic arrays also. SWRAD1A.16
CLL SWRAD1A.17
CLL Option CCLD3, set if A01_2A is chosen, combines the AWI3F304.1
CLL layer clouds so that at each point the plug-compatible SW only SWRAD1A.20
CLL sees one layer cloud of each "type" ("high", "medium" and "low") SWRAD1A.21
CLL - as well as the convective tower, of course. The boundaries SWRAD1A.22
CLL between these types are defined in terms of eta, and the model eta SWRAD1A.23
CLL values passed in are used to convert these to layer numbers. SWRAD1A.24
CLL These layer cloud amounts reduced to 3 layers are also made SWRAD1A.25
CLL available as diagnostics. William Ingram 8/10/92 SWRAD1A.26
CLL Author: William Ingram SWRAD1A.34
CLL SWRAD1A.35
CLL Model Modification history from model version 3.0: SWRAD1A.36
CLL version Date SWRAD1A.37
CLL 3.4 31/8/94 nupdate *IFs replaced by FORTRAN IFs (W Ingram) AWI3F304.2
CLL 3.4 31/8/94 Compiling system directives added (W Ingram) AWI1F304.1
CLL 4.0 1/2/95 SWOUT zeroed at ALL night points for safety. WJI AWI1F400.14
!LL 4.0 28/9/95 FOCWWIL COMDECK now subroutine CALL. (A Bushell) AYY2F400.289
CLL 4.1 17.1.95 NSSSB1 is renamed NSSB1 and is now set over all AJS1F401.1364
CLL points instead of over sea surface only; needed AJS1F401.1365
CLL over land to derive downward SW in band 1 (TDSSB1) AJS1F401.1366
CLL which provides photosynthetically active radiation AJS1F401.1367
CLL for vegetation model in Section 3. This is added AJS1F401.1368
CLL to the SWOUT array as an 'extra level', without AJS1F401.1369
CLL Zenith Angle adjustment, to enable use in all AWI2F402.1
CLL physics timesteps. (R A Betts) AJS1F401.1371
CLL AJS1F401.1372
CLL 4.2 Sept.96 T3E migration: *DEF CRAY removed; GSS1F402.26
CLL *DEF T3E used for T3E library functions; GSS1F402.27
CLL dynamic allocation no longer *DEF controlled. GSS1F402.28
CLL S.J.Swarbrick GSS1F402.29
! 4.4 01/7/97 Allow replacement of FOCWWIL parametrization by AYY1F404.264
! direct ratio of prognostic cloud ice to liquid AYY1F404.265
! in _LAYER_ cloud calculations. Note that FOCWWIL is AYY1F404.266
! also used to partition CONVECTIVE cloud and thus is AYY1F404.267
! retained. (A C Bushell) AYY1F404.268
CLL SWRAD1A.38
CLL It technically conforms with standard A of UMDP 4 (version 3, SWRAD1A.39
CLL 07/9/90), but makes many assumptions about STASH structure, and is SWRAD1A.40
CLL not plug-compatible. SWRAD1A.41
CLL SWRAD1A.42
CLL It is part of component P233 (ancillary calculations for the SWRAD1A.43
CLL shortwave radiation), which is in task P23 (radiation). It also SWRAD1A.44
CLL performs some of the functions of D23 (radiation diagnostics). SWRAD1A.45
CLL SWRAD1A.46
CLL Offline documentation (where appropriate) is in UMDP 23. SWRAD1A.47
CLLEND -------------------------------------------------------------- SWRAD1A.48
C*L SWRAD1A.49
SUBROUTINE SWRAD (H2OIN, CO2, O3IN, PSTIN, ABIN, BBIN, LCAIN, 3,10SWRAD1A.50
& LCW1IN, LCW2IN, CCAIN, CCWPIN, CCBIN, CCTIN, SALIIN, SAOSIN, SWRAD1A.51
& AICE, COSZIN, LIT, LAND, LIST, TAC, SCS, LUT, PTS, SWRAD1A.52
& OSDIA, OSON, CSOSDI, CSOSON, NSSB1, NSS1ON, TDSS, TDSSON, AJS1F401.1373
& CSSSD, CSSSDO, CSSSU, CSSSUO, LCASW, LCASWO, CCASW, CCASWO, SWRAD1A.54
& LCAAR, LCAARO, LCAARL, LCAARB, LCAAF, LCAAFO, LCAAFL, LCAAFB, SWRAD1A.55
& CCAAR, CCAARO, CCAARB, CCAAF, CCAAFO, CCAAFB, TCASW, TCASWO, SWRAD1A.56
& CREFF,CREFFO,LREFF,LREFFO,CVAMT,CVAMTO,LRAMT,LRAMTO, AAJ1F304.7
& CWPAJ,CWPAJON,MICRO, AAJ1F304.8
& LCA3L, LCA3ON, LCLD3, AWI3F304.3
& L_CLOUD_WATER_PARTITION, AYY1F404.269
& NLIT, NDO, NLEVS, NCLDS, NWET, NOZONE, L1, GSS1F402.30
& NTSWIN, SWSEA, SWOUT) SWRAD1A.63
EXTERNAL SWMAST, SWDTCA, LSP_FOCWWIL AYY2F400.290
C* AYY2F400.291
! EITHER AYY1F404.270
! Use temperature dependent focwwil for convection but calculate AYY1F404.271
! ratio in layer cloud from prognostic cloud ice produce as part AYY1F404.272
! of large-scale precipitation scheme 3A, OR AYY1F404.273
! Use the subroutine LSP_FOCWWIL (from Section 4) consistently to AYY2F400.292
C ! derive cloud radiative properties and precipitation amount, SWRAD1A.69
C ! taking into account that cloud does not freeze as soon as it is SWRAD1A.70
C ! cooled below the freezing point of bulk water. The release of SWRAD1A.71
C ! latent heat of fusion (not a major term) is done differently in SWRAD1A.72
C ! order to allow energy conservation (UMDP 29). This is the SWRAD1A.73
C ! reason for two layer cloud water contents being passed in and SWRAD1A.74
C ! then combined and differently split. SWRAD1A.75
C SWRAD1A.76
C ! Dimensions: SWRAD1A.77
*CALL SWNBANDS 
SWRAD1A.78
*CALL SWNGASES SWRAD1A.79
*CALL SWNTRANS SWRAD1A.80
*CALL SWLKUPPA SWRAD1A.81
INTEGER!, INTENT(IN) :: SWRAD1A.83
& L1, ! Number of points in input arrays SWRAD1A.84
& NDO, ! Number of points to be treated SWRAD1A.85
& NLIT, ! Number of them to be sunlit SWRAD1A.86
& NLEVS, ! Number of levels SWRAD1A.87
& NCLDS, ! Number of possibly cloudy levels SWRAD1A.88
& NWET, ! Number of levels with water vapor SWRAD1A.89
& NOZONE ! Number of levels with ozone SWRAD1A.90
C ! Physical inputs: SWRAD1A.99
REAL!, INTENT(IN) :: SWRAD1A.100
& H2OIN(L1,NWET), CO2, ! Mass mixing ratios of SWRAD1A.101
& O3IN(L1,NOZONE), ! absorbing gases SWRAD1A.102
& PSTIN(L1), ! Surface pressure SWRAD1A.103
& ABIN(NLEVS+1), BBIN(NLEVS+1), ! As and Bs at layer boundaries SWRAD1A.104
& LCAIN(L1,1/(NCLDS+1)+NCLDS), ! Layer cloud fractional cover SWRAD1A.105
& LCW1IN(L1,1/(NCLDS+1)+NCLDS), ! Layer cloud frozen and liquid SWRAD1A.106
& LCW2IN(L1,1/(NCLDS+1)+NCLDS), ! water contents SWRAD1A.107
C ! These are specific cloud water contents, mass per unit mass, SWRAD1A.108
C ! and, as explained above, only their sum is used. SWRAD1A.109
& CCAIN(L1), ! Convective Cloud Amount SWRAD1A.110
& CCWPIN(L1), ! and condensed water path SWRAD1A.111
& SALIIN(L1), ! (True) Surface Albedo for SWRAD1A.112
& SAOSIN(L1,2), ! land & ice, for & open sea SWRAD1A.113
& COSZIN(L1), ! Mean (cos solar zenith angle) SWRAD1A.114
C ! while the point is sunlit SWRAD1A.115
& LIT(L1), ! Fraction the point is sunlit SWRAD1A.116
& TAC(L1,NLEVS), ! Atmospheric temperatures SWRAD1A.117
& AICE(L1), ! Sea-ice fraction SWRAD1A.118
& SCS, ! Solar Constant Scaling factor SWRAD1A.119
C ! - inverse-square factor which multiplies the solar constant to SWRAD1A.120
C ! get the normal solar irradiance at this day's earth-sun distance SWRAD1A.121
& LUT(NLKUPS,NTRANS,NGASES,2), SWRAD1A.122
C ! Look-up tables of transmissivities for each gas and of SWRAD1A.123
C ! differences of their successive elements. SWRAD1A.124
& PTS ! Time interval at which the SWRAD1A.125
C ! increments to be returned are to be added in ("physics SWRAD1A.126
C ! timestep"). The time interval over which they are valid SWRAD1A.127
C ! ("shortwave timestep") is not used directly here, but as an SWRAD1A.128
C ! input to the astronomy code it affects COSZIN, LIT and LIST. SWRAD1A.129
INTEGER!, INTENT(IN) :: SWRAD1A.130
& LIST(NLIT), ! List of the NLIT sunlit points SWRAD1A.131
& CCBIN(L1), ! Convective cloud base & top, SWRAD1A.132
& CCTIN(L1) ! layer boundaries counting up from SWRAD1A.133
C ! the surface as 1 SWRAD1A.134
C ! Control quantities: SWRAD1A.135
LOGICAL!, INTENT(IN) :: SWRAD1A.136
& LAND(L1) ! Land/sea mask (.TRUE. for land) SWRAD1A.137
& , OSON, CSOSON ! Are OSDIA & CSOSDI wanted ? AJS1F401.1374
& , NSS1ON, TDSSON ! And are NSSSB1 and TDSS ? SWRAD1A.139
& , CREFFO, LREFFO ! And are CREFF and LREFF... AAJ1F304.9
& , CVAMTO, LRAMTO ! ... and CVAMT and LRAMT ? AAJ1F304.10
& , CWPAJON ! Is CWP O/P wanted? AAJ1F304.11
& , MICRO ! Is microphysics code activated? AAJ1F304.12
& , LCA3ON ! And is LCA3L ? SWRAD1A.141
C ! Note that if LCLD3, LCA3L is needed to calculate TCASW & so AWI2F402.2
C ! will be calculated whenever TCASWO or LCA3ON - so space must AWI2F402.3
C ! then be available (via "implied diagnostics" in the std UM). AWI2F402.4
& , CSSSDO, CSSSUO ! & are CSSSD & CSSSU, SWRAD1A.143
& , LCASWO, CCASWO ! LCASW & CCASW, SWRAD1A.144
& , LCAARO, LCAAFO ! LCAAR & LCAAF, SWRAD1A.145
& , CCAARO, CCAAFO ! CCAAR & CCAAF, SWRAD1A.146
& , TCASWO ! & TCASW ? SWRAD1A.147
& , LCAARL(NCLDS), LCAARB(NBANDS), LCAAFL(NCLDS) SWRAD1A.148
& , LCAAFB(NBANDS), CCAARB(NBANDS), CCAAFB(NBANDS) SWRAD1A.149
C ! If L/C CAA R/F are wanted, for which (levels and) bands ? SWRAD1A.150
& , LCLD3 AWI3F304.4
& , L_CLOUD_WATER_PARTITION AYY1F404.274
C ! And outputs: SWRAD1A.151
REAL!, INTENT(OUT) :: SWRAD1A.152
& SWOUT(L1,NLEVS+2), ! This is filled by SWMAST with the AJS1F401.1375
C ! normalized net downward shortwave flux at all layer boundaries. SWRAD1A.154
C ! SWRAD multiplies them by the normal incoming insolation to give SWRAD1A.155
C ! dimensioned fluxes (still not the actual fluxes as the cosz SWRAD1A.156
C ! term is not put in here) and differences them in the vertical SWRAD1A.157
C ! to give SW heating rates (except for the cosz) in each SWRAD1A.158
C ! atmospheric layer, leaving a surface net downward SW flux in SWRAD1A.159
C ! the first level for use in the surface scheme. It also SWRAD1A.160
C ! modifies the latter so that it refers to land-and-ice only (the SWRAD1A.161
C ! surfaces dealt with in the atmospheric model), being the value SWRAD1A.162
C ! over that surface (except the cosz) times the fraction of the SWRAD1A.163
C ! grid-box covered by land or sea-ice. SWRAD1A.164
C ! The 'level' NLEV+2 holds NSSB1 without Zenith Angle AJS1F401.1376
C ! adjustment,for use in physics timesteps in RAD_CTL and CLD_CTL AJS1F401.1377
& SWSEA(L1) ! The net downward SW flux over SWRAD1A.165
C ! open sea. SWMAST returns this normalized and SWRAD converts SWRAD1A.166
C ! it into an actual flux with weighting by the open sea fraction SWRAD1A.167
C ! (so that it can be added to the corresponding land-and-ice SWRAD1A.168
C ! term to give the overall net downward SW flux.) SWRAD1A.169
& , NTSWIN(L1) ! Net SW absorption by the planet SWRAD1A.170
& , OSDIA(L1) ! Diagnosed actual and clear-sky SWRAD1A.171
& , CSOSDI(L1) ! outgoing solar at toa SWRAD1A.172
& , CSSSD(L1) ! Clear-sky total downward & SWRAD1A.173
& , CSSSU(L1) ! upward SW flux at the surface SWRAD1A.174
& , LCASW(L1,NCLDS) ! Layer/Convective Cloud Amount WI250593.2
& , CCASW(L1) ! in SW (zero at night points) SWRAD1A.176
& , LCAAR(L1,*) ! Layer/Convective Cloud Amount * SWRAD1A.177
& , LCAAF(L1,*) ! Albedo to diRect and diFfuse SWRAD1A.178
& , CCAAR(L1,*) ! light (set to zero at night SWRAD1A.179
& , CCAAF(L1,*) ! points) SWRAD1A.180
& , TCASW(L1) ! Total cloud amount in SW SWRAD1A.181
C ! (i.e. fraction of the grid-box with cloud at some level) SWRAD1A.182
& , NSSB1(L1) AJS1F401.1378
C ! Net downward SW flux at the surface in band 1 AJS1F401.1379
& , TDSS(L1) SWRAD1A.185
C ! Total downward SW flux at the surface (multiply-reflected SWRAD1A.186
C ! light being multiply counted). SWRAD1A.187
& , TDSSB1(L1) AJS1F401.1380
C ! Total downward SW flux at surface in band 1 AJS1F401.1381
& , CREFF(L1) ! Convective cloud rE * cld amount AAJ1F304.13
& , LREFF(L1,NCLDS) ! Layer cloud rE * cld amount AAJ0F400.1
& , CVAMT(L1) ! Convective cloud amount in SWRAD AAJ1F304.15
& , LRAMT(L1,NCLDS) ! Layer cloud amount in SWRAD AAJ0F400.2
& , CWPAJ(L1,NCLDS) ! Lyr cld CWP for 3-cld scheme AAJ0F400.3
& , LCA3L(L1,NCLDS) ! Diagnostic of layer cloud amount SWRAD1A.189
C ! restricted to 3 layers, calculated at all points on SW timesteps SWRAD1A.190
C* SWRAD1A.192
C ! Constants: SWRAD1A.193
*CALL C_0_DG_C SWRAD1A.194
*CALL C_R_CP SWRAD1A.195
*CALL C_G SWRAD1A.196
*CALL C_PI AAJ1F304.18
*CALL C_DENSTY AAJ1F304.19
*CALL C_MICRO AAJ1F304.20
REAL CPBYG ! Helps convert fluxes to SWRAD1A.197
PARAMETER ( CPBYG = CP / G ) ! heating rates SWRAD1A.198
*CALL SWSC SWRAD1A.199
*CALL SWRE SWRAD1A.200
REAL COSMIN ! Minimum value for COSZ, to SWRAD1A.201
PARAMETER ( COSMIN = 1.E-4 ) ! avoid underflow in SWCLOP SWRAD1A.202
C ! Local variables: SWRAD1A.203
REAL NSI, ! Normal Solar Irradiance SWRAD1A.204
& TEMPOR, ! Temporary store SWRAD1A.205
& DACON1, DBCON1, ! Conversion factors for turning SWRAD1A.206
C ! fluxes into increments - difference of As and Bs across the SWRAD1A.207
C ! current layer, times CPBYG and divided by the timestep. SWRAD1A.208
& DACON2, DBCON2 ! Conversion factors for turning SWRAD1A.209
C ! mixing ratio into pathlength - difference of As and Bs across SWRAD1A.210
C ! the current layer, divided by g. SWRAD1A.211
REAL DCONRE, ! Cloud droplet rE for deep convective clouds. AAJ1F304.21
& SCONRE, ! " " " " shallow " " . AAJ1F304.22
& NTOT, ! Total CCN concentration (/m**3). AAJ1F304.23
& KPARAM, ! k parameter (=rV/rE). AAJ1F304.24
& PCCTOP, ! Convective cloud top pressure. AAJ1F304.25
& PCCBOT, ! " " base " . AAJ1F304.26
& LCMMR, ! Layer cloud mass mixing ratio (kg/kg). AAJ1F304.27
& LWC, ! Cloud liquid water content (kg/m**3). AAJ1F304.28
& RHOAIR, ! Local density of air (kg/m**3). AAJ1F304.29
& DELTAZ, ! Thickness of convective cloud (m). AAJ1F304.30
& PRESS1, ! Pressure at bottom... AAJ1F304.31
& PRESS2, ! ...and top of layer boundaries. AAJ1F304.32
& TAU, ! Area-averaged optical depth. AAJ1F304.33
& L1AJ ! Cloud amount dummy-variable. AAJ1F304.34
C AAJ1F304.35
C*L SWRAD1A.212
CL ! Dynamically allocated workspace: SWRAD1A.213
C ! 3*NDO+ NLIT*(3*NCLDS+NWET+NOZONE+4*NBANDS+8) +2*(NLEVS+1) SWRAD1A.214
REAL H2OGI(NLIT,NWET), ! Gathered and inverted inputs: SWRAD1A.215
& O3GI(NLIT,NOZONE), ! just as the corresponding SWRAD1A.216
& PSTGI(NLIT), ! ...IN arrays, except that the SWRAD1A.217
& ABGI(NLEVS+1), BBGI(NLEVS+1), ! two LCW arrays are combined, SWRAD1A.218
& LCAGI(NLIT,NCLDS), ! since the ice/liquid split is SWRAD1A.219
& LCWPGI(NLIT,NCLDS), ! done differently for SWRAD1A.220
& CCAGI(NLIT), ! radiation and precipitation SWRAD1A.221
& CCWPGI(NLIT), ! than for latent heat release, SWRAD1A.222
& COSZGI(NLIT), ! and also converted from cloud SWRAD1A.223
& ! water content to path. SWRAD1A.224
& SAGI(NLIT,NBANDS,2), ! Gathered surface albedos for SWRAD1A.225
& SAOSGI(NLIT,NBANDS,2) ! each band, for the whole SWRAD1A.226
C ! grid-box and open sea only (for SWMAST to calculate SWSEA with) SWRAD1A.227
C SWRAD1A.228
INTEGER CCBGI(NLIT), ! Convective cloud base & top, SWRAD1A.229
& CCTGI(NLIT) ! layers counting down from the SWRAD1A.230
C ! top layer as 1 SWRAD1A.231
& , INDEX(NDO) SWRAD1A.233
C ! Index for maximum(input)/only(used) cloud cover for a "type" SWRAD1A.234
C ! (This, and MAXCLD below, are dimensioned NDO rather than NLIT SWRAD1A.235
C ! because full field size is used if LCA3L is wanted.) SWRAD1A.236
REAL CRE(NLIT), ! Equivalent radii calculated SWRAD1A.238
& LRE(NLIT,NCLDS), ! as functions of temperature. SWRAD1A.239
& LAYERE(NLIT,NCLDS), ! Liquid-only rE AAJ1F304.36
& CWPAJGI(NLIT,NCLDS), ! CWP gathered & inverted AAJ1F304.37
& MAXCLD(NDO), ! Maximum cloud cover & total SWRAD1A.241
& TOTCWC(NLIT), ! water content for a "type" SWRAD1A.242
& IITOA(NDO) ! Incoming Insolation at the SWRAD1A.244
C ! Top Of the Atmosphere SWRAD1A.245
C* SWRAD1A.246
INTEGER LEVEL, J, ! Loopers over level and point SWRAD1A.247
& BAND, ! and band. SWRAD1A.248
& OFFSET, ! Index for diagnostics SWRAD SWRAD1A.249
C ! returns (potentially) compressed, allowing just the bands or SWRAD1A.250
C ! level-and-band combinations wanted to be allocated and set. SWRAD1A.251
& DIRDIF, ! and direct/diffuse albedos SWRAD1A.252
& TYPE, ! & cloud "type" (H/M/L) SWRAD1A.254
& RANGE(3,2), ! The range of level numbers SWRAD1A.255
C ! (counting down from the highest potentially cloudy level) for SWRAD1A.256
C ! the 3 cloud "types" - i.e. the RANGE(n,1)th to RANGE(n,2)th SWRAD1A.257
C ! potentially cloudy levels are assigned to the nth cloud type. SWRAD1A.258
C ! The values are set by comparing model eta values with BOUNDS. SWRAD1A.259
& FSTLEV, ! The equivalent of RANGE for SWRAD1A.260
& LSTLEV, ! a particular cloud type, but SWRAD1A.261
C ! counting up from the surface SWRAD1A.262
& NCLEAR, ! NLEVS-NCLDS SWRAD1A.264
& NNIGHT, ! NDO-NLIT SWRAD1A.265
& NLP1B2 ! (NLEVS+1)/2 SWRAD1A.266
REAL BOUNDS(2), ! Eta values that define where SWRAD1A.268
C ! cloud changes from "high" to "medium", & from "medium" to "low" SWRAD1A.269
& ETA, ! Eta at the layer boundary SWRAD1A.270
C ! ! currently being checked SWRAD1A.271
& ETALST ! & the previous one SWRAD1A.272
& , FOCWWIL AYY2F400.293
! Local value of Fraction Of Cloud Water Which Is Liquid AYY2F400.294
& , TFOC AYY2F400.295
! and the cloud temperature used to calculate it. AYY2F400.296
LOGICAL SET ! Has RANGE been set yet ? SWRAD1A.273
DATA BOUNDS / .37, .79 / SWRAD1A.274
DATA SET / .FALSE. / SWRAD1A.275
SAVE RANGE, SET ! SET must be specified too as SWRAD1A.276
C ! FORTRAN requires a variable initialized by a DATA statement to SWRAD1A.277
C ! have the SAVE attribute only if its value has not changed. SWRAD1A.278
IF (MICRO) THEN AAJ1F304.38
AAJ1F304.39
C Zero effective radius arrays if diagnostics requested: AAJ1F304.40
IF (CREFFO) THEN AAJ1F304.41
DO II=1, NDO AWI2F402.5
CREFF(II) = 0.0 AAJ1F304.43
END DO AAJ1F304.44
END IF AAJ1F304.45
IF (LREFFO) THEN AAJ1F304.46
DO JJ=1, NCLDS AAJ0F400.4
DO II=1, NDO AWI2F402.6
LREFF(II,JJ) = 0.0 AAJ1F304.49
END DO AAJ1F304.50
END DO AAJ1F304.51
END IF AAJ1F304.52
C Zero Cloud-Amount-In-SWRAD arrays if diagnostics requested: AAJ1F304.53
IF (CVAMTO) THEN AAJ1F304.54
DO II=1, NDO AWI2F402.7
CVAMT(II) = 0.0 AAJ1F304.56
END DO AAJ1F304.57
END IF AAJ1F304.58
IF (LRAMTO) THEN AAJ1F304.59
DO JJ=1, NCLDS AAJ0F400.5
DO II=1, NDO AWI2F402.8
LRAMT(II,JJ) = 0.0 AAJ1F304.62
END DO AAJ1F304.63
END DO AAJ1F304.64
END IF AAJ1F304.65
C Zero Layer-Cloud-CWP-In-SWRAD arrays if diagnostics requested: AAJ1F304.66
IF (CWPAJON) THEN AAJ1F304.67
DO JJ=1, NCLDS AAJ0F400.6
DO II=1, NDO AWI2F402.9
CWPAJ(II,JJ)=0.0 AAJ1F304.70
END DO AAJ1F304.71
END DO AAJ1F304.72
END IF AAJ1F304.73
AAJ1F304.74
END IF AAJ1F304.75
AAJ1F304.76
CL SWRAD1A.280
CL ! Section 1 - invert and gather input data for SWMAST SWRAD1A.281
CL ~~~~~~~~~ SWRAD1A.282
CL ! As & Bs of course only need inverting: SWRAD1A.283
Cfpp$ NoConcur L SWRAD1A.284
DO 11 LEVEL=1, NLEVS+1 SWRAD1A.285
ABGI(LEVEL) = ABIN(NLEVS+2-LEVEL) SWRAD1A.286
BBGI(LEVEL) = BBIN(NLEVS+2-LEVEL) SWRAD1A.287
11 CONTINUE SWRAD1A.288
NCLEAR = NLEVS - NCLDS SWRAD1A.289
C SWRAD1A.290
CL ! &, if LCLD3 is on, the first time into the routine, find where AWI3F304.5
CL ! cloud type boundaries will lie in terms of the numbering of this AWI3F304.6
CL ! run's eta levels: AWI3F304.7
C AWI3F304.8
IF ( LCLD3 .AND. .NOT. SET ) THEN AWI3F304.9
RANGE(1,1) = 1 SWRAD1A.296
LEVEL = NCLEAR + 1 SWRAD1A.297
DO J=1, 2 SWRAD1A.298
101 ETA = BBGI(LEVEL) + ABGI(LEVEL) / PREF SWRAD1A.299
IF ( ETA .LT. BOUNDS(J) ) THEN SWRAD1A.300
LEVEL = LEVEL + 1 SWRAD1A.301
ETALST = ETA SWRAD1A.302
C ! This assumes the vertical resolution is not too crude in SWRAD1A.303
C ! the troposphere - but it would have to be rather worse SWRAD1A.304
C ! even than the old 11-layer Cyber climate model. SWRAD1A.305
GO TO 101 SWRAD1A.306
ELSE SWRAD1A.307
C ! This has found the first layer boundary below BOUNDS - SWRAD1A.308
C ! is this or the previous one closer ? SWRAD1A.309
IF ( BOUNDS(J)-ETALST .LT. ETA-BOUNDS(J) ) LEVEL = LEVEL-1 SWRAD1A.310
RANGE(J+1,1) = LEVEL - NCLEAR SWRAD1A.311
RANGE(J,2) = RANGE(J+1,1) - 1 SWRAD1A.312
ENDIF SWRAD1A.313
ENDDO SWRAD1A.314
RANGE(3,2) = NCLDS SWRAD1A.315
SET = .TRUE. SWRAD1A.316
ENDIF SWRAD1A.317
C SWRAD1A.318
C SWRAD1A.320
CL ! while single-level or no-level data would just need gathering SWRAD1A.321
C ! - except that convective cloud rE must be calculated from the SWRAD1A.322
C ! temperature of the highest layer the cloud extends into, and SWRAD1A.323
C ! convective cloud base and top must be altered to count from the SWRAD1A.324
C ! top down and to refer to layer centres rather than layer SWRAD1A.325
C ! boundaries, and constrained to have a valid value (where CCA=0, SWRAD1A.326
! P27 does not set CCB or CCT.) MAXCLD is used as temporary AYY2F400.297
! storage for the gathered temperature input to ROCWWIP (also AYY2F400.298
! used later by the microphsyics option), and CRE for the output. AYY2F400.299
DO J=1, NLIT AYY2F400.300
PSTGI(J) = PSTIN(LIST(J)) SWRAD1A.329
CCAGI(J) = CCAIN(LIST(J)) SWRAD1A.330
CCWPGI(J)= CCWPIN(LIST(J)) SWRAD1A.331
C ! Conversion of CCWP here omitted for the time being. SWRAD1A.332
COSZGI(J)= COSZIN(LIST(J)) SWRAD1A.333
IF ( COSZGI(J) .LT. COSMIN ) COSZGI(J) = COSMIN SWRAD1A.334
CCTGI(J) = NLEVS+2 - CCTIN(LIST(J)) SWRAD1A.335
IF ( CCTGI(J) .GT. NLEVS .OR. CCTGI(J) .LE. NCLEAR ) SWRAD1A.336
& CCTGI(J) = NCLEAR + 1 WI200893.15
CCBGI(J) = NLEVS+1 - CCBIN(LIST(J)) SWRAD1A.338
IF ( CCBGI(J) .GT. NLEVS .OR. CCBGI(J) .LE. NCLEAR ) SWRAD1A.339
& CCBGI(J) = NLEVS SWRAD1A.340
C ! CCTGI (where it was defined) was indexed similarly to TAC, but SWRAD1A.341
C ! we would have to subtract 1 to get the temperature at the SWRAD1A.342
C ! layer centre BELOW the layer boundary indicated by CCT. To SWRAD1A.343
C ! be sure we do not access outside the valid range, we must SWRAD1A.344
C ! actually use CCTGI, which makes it a little less clear. SWRAD1A.345
MAXCLD(J) = TAC(LIST(J),NLEVS+1-CCTGI(J)) AYY2F400.301
END DO AYY2F400.302
CALL LSP_FOCWWIL (MAXCLD, NLIT, CRE) AYY2F400.303
DO J=1, NLIT AYY2F400.304
TFOC = MAXCLD(J) AYY2F400.305
FOCWWIL = CRE(J) AYY2F400.306
IF (MICRO) THEN AAJ1F304.77
AAJ1F304.78
IF (LAND(LIST(J))) THEN AAJ1F304.79
DCONRE = DCONRE_LAND ! Continental clouds. AAJ1F304.80
KPARAM = KPARAM_LAND AAJ1F304.81
NTOT = NTOT_LAND AAJ1F304.82
ELSE AAJ1F304.83
DCONRE = DCONRE_SEA ! Maritime clouds. AAJ1F304.84
KPARAM = KPARAM_SEA AAJ1F304.85
NTOT = NTOT_SEA AAJ1F304.86
END IF AAJ1F304.87
IF (CCAGI(J).LE.0.0) THEN AAJ1F304.88
CRE(J)=0.0 ! Set rE to zero for no cloud. AAJ1F304.89
ELSE AAJ1F304.90
PCCTOP=ABIN(CCTIN(LIST(J)))+BBIN(CCTIN(LIST(J)))*PSTGI(J) AAJ1F304.91
PCCBOT=ABIN(CCBIN(LIST(J)))+BBIN(CCBIN(LIST(J)))*PSTGI(J) AAJ1F304.92
DELTAZ=(R*TFOC/G)*ALOG(PCCBOT/PCCTOP) AAJ1F304.93
IF (DELTAZ .LT. 500.0) THEN ! Shallow convection. AAJ1F304.94
LWC=(CCWPGI(J)/DELTAZ) AAJ1F304.95
SCONRE=(3.0*LWC/(4.0*PI*RHO_WATER*KPARAM*NTOT))**(1.0/3.0) AAJ1F304.96
CRE(J)=REICE+(SCONRE-REICE)*FOCWWIL AAJ1F304.97
C Set safe rE limits (for SWCLOP): AAJ1F304.98
IF (CRE(J).LT.0.35E-06) CRE(J)=0.35E-06 AAJ1F304.99
IF (CRE(J).GT.37.0E-06) CRE(J)=37.0E-06 AAJ1F304.100
ELSE AAJ1F304.101
CRE(J)=REICE+(DCONRE-REICE)*FOCWWIL ! Deep convection. AAJ1F304.102
END IF AAJ1F304.103
END IF AAJ1F304.104
IF (CREFFO) CREFF(LIST(J))=CRE(J) * CCAGI(J) * 1000000.0 AAJ1F304.105
IF (CVAMTO) CVAMT(LIST(J))=CCAGI(J) * 1000000.0 AAJ1F304.106
AAJ1F304.107
ELSE AAJ1F304.108
AAJ1F304.109
CRE(J) = REICE + DRE * FOCWWIL SWRAD1A.348
AAJ1F304.110
END IF AAJ1F304.111
AAJ1F304.112
ENDDO AYY2F400.307
C SWRAD1A.350
CL ! Water is gathered and inverted at NWET levels: SWRAD1A.351
DO 14 LEVEL=1, NWET SWRAD1A.352
Cfpp$ Select(CONCUR) SWRAD1A.353
DO 14 J=1, NLIT SWRAD1A.354
H2OGI(J,LEVEL) = H2OIN(LIST(J),NWET+1-LEVEL) SWRAD1A.355
14 CONTINUE SWRAD1A.356
C SWRAD1A.357
CL ! and ozone at NOZONE... SWRAD1A.358
DO 15 LEVEL=1, NOZONE SWRAD1A.359
Cfpp$ Select(CONCUR) SWRAD1A.360
DO 15 J=1, NLIT SWRAD1A.361
O3GI(J,LEVEL) = O3IN(LIST(J),NOZONE+1-LEVEL) SWRAD1A.362
15 CONTINUE SWRAD1A.363
C SWRAD1A.364
CL ! Layer cloud data are gathered and inverted at NCLDS levels. SWRAD1A.365
C ! rE is calculated as for convective cloud, SWRAD1A.366
C ! and also QL & QF are added together. SWRAD1A.367
DO 16 LEVEL=1, NCLDS SWRAD1A.368
DACON2 = ( ABIN(NCLDS+1-LEVEL) - ABIN(NCLDS+2-LEVEL) ) / G SWRAD1A.369
DBCON2 = ( BBIN(NCLDS+1-LEVEL) - BBIN(NCLDS+2-LEVEL) ) / G SWRAD1A.370
Cfpp$ Select(CONCUR) SWRAD1A.371
DO J=1, NLIT AYY2F400.308
LCAGI(J,LEVEL) = LCAIN(LIST(J),NCLDS+1-LEVEL) SWRAD1A.373
MAXCLD(J) = TAC(LIST(J),NCLDS+1-LEVEL) AYY2F400.309
END DO AYY2F400.310
IF (L_CLOUD_WATER_PARTITION) THEN AYY1F404.275
! calculate proportion of liquid water focwwil as ratio qcl/(qcl+qcf) AYY1F404.276
DO J=1, NLIT AYY1F404.277
IF (LCAGI(J,LEVEL) .GT. 0.) THEN AYY1F404.278
LRE(J,LEVEL) = LCW1IN(LIST(J),NCLDS+1-LEVEL) / AYY1F404.279
& (LCW1IN(LIST(J),NCLDS+1-LEVEL)+LCW2IN(LIST(J),NCLDS+1-LEVEL)) AYY1F404.280
ELSE AYY1F404.281
! Arbitrary number: makes it safe & vectorizable AYY1F404.282
LRE(J,LEVEL) = 0.0 AYY1F404.283
ENDIF AYY1F404.284
END DO AYY1F404.285
ELSE AYY1F404.286
! set proportion of liquid water focwwil from parametrized function AYY1F404.287
CALL LSP_FOCWWIL (MAXCLD, NLIT, LRE(1,LEVEL)) AYY1F404.288
ENDIF AYY1F404.289
! AYY1F404.290
DO J=1, NLIT AYY2F400.312
TFOC = MAXCLD(J) AYY2F400.313
FOCWWIL = LRE(J,LEVEL) AYY2F400.314
IF (MICRO) THEN AAJ1F304.113
AAJ1F304.114
IF (LAND(LIST(J))) THEN AAJ1F304.115
KPARAM = KPARAM_LAND AAJ1F304.116
NTOT = NTOT_LAND AAJ1F304.117
ELSE AAJ1F304.118
KPARAM = KPARAM_SEA AAJ1F304.119
NTOT = NTOT_SEA AAJ1F304.120
END IF AAJ1F304.121
LCMMR = ( LCW1IN(LIST(J), NCLDS+1-LEVEL) AAJ1F304.122
& + LCW2IN(LIST(J), NCLDS+1-LEVEL) ) AAJ1F304.123
IF (LCAGI(J,LEVEL) .GT. 0.0) THEN AAJ1F304.124
LCMMR = LCMMR / LCAGI(J,LEVEL) AAJ1F304.125
PRESS1=ABIN(NCLDS+1-LEVEL)+BBIN(NCLDS+1-LEVEL)*PSTGI(J) AAJ1F304.126
PRESS2=ABIN(NCLDS+2-LEVEL)+BBIN(NCLDS+2-LEVEL)*PSTGI(J) AAJ1F304.127
RHOAIR=(EXP((ALOG(PRESS1)+ALOG(PRESS2))/2.0)) / (R*TFOC) AAJ1F304.128
LWC=LCMMR * RHOAIR AAJ1F304.129
IF (LEVEL .GE. RANGE(3,1)) THEN ! Low cloud AAJ1F304.130
LAYERE(J,LEVEL)=(6.0*LWC/(4.0*PI*RHO_WATER*KPARAM*NTOT)) AAJ1F304.131
& **(1.0/3.0) AAJ1F304.132
ELSE AAJ1F304.133
LAYERE(J,LEVEL)=(3.0*LWC/(4.0*PI*RHO_WATER*KPARAM*NTOT)) AAJ1F304.134
& **(1.0/3.0) AAJ1F304.135
END IF AAJ1F304.136
LRE(J,LEVEL)=REICE+(LAYERE(J,LEVEL)-REICE)*FOCWWIL AAJ1F304.137
C Set safe rE limits (for SWCLOP): AAJ1F304.138
IF (LRE(J,LEVEL).LT.0.35E-06) LRE(J,LEVEL)=0.35E-06 AAJ1F304.139
IF (LRE(J,LEVEL).GT.37.0E-06) LRE(J,LEVEL)=37.0E-06 AAJ1F304.140
ELSE AAJ1F304.141
LRE(J,LEVEL)=0.0 AAJ1F304.142
LAYERE(J,LEVEL)=0.0 AAJ1F304.143
END IF AAJ1F304.144
AAJ1F304.145
ELSE AAJ1F304.146
AAJ1F304.147
LRE(J,LEVEL) = REICE + DRE * FOCWWIL SWRAD1A.376
AAJ1F304.148
END IF AAJ1F304.149
AAJ1F304.150
LCWPGI(J,LEVEL) = ( DACON2 + DBCON2 * PSTGI(J) ) * SWRAD1A.377
& ( LCW1IN(LIST(J),NCLDS+1-LEVEL) + LCW2IN(LIST(J),NCLDS+1-LEVEL) ) SWRAD1A.378
IF ( ( .NOT. LCLD3 ) .AND. LCAGI(J,LEVEL) .GT. 0. ) AWI3F304.10
& LCWPGI(J,LEVEL)= LCWPGI(J,LEVEL) / LCAGI(J,LEVEL) SWRAD1A.381
END DO AYY2F400.315
16 CONTINUE SWRAD1A.383
CL ! If the option to combine layer clouds into 3 layers is on, do so AWI3F304.11
IF ( LCLD3 ) THEN AWI3F304.12
C SWRAD1A.385
CL ! Now, find which layer holds most cloud of each "type": SWRAD1A.386
C ! (The loops over TYPE, and over LEVEL inside them, are from the WI250593.3
C ! top down, as usual for loops involving TYPE or ..GI arrays.) WI250593.4
C SWRAD1A.387
DO TYPE=1, 3 SWRAD1A.388
Cfpp$ Select(CONCUR) SWRAD1A.389
DO J=1, NLIT SWRAD1A.390
TOTCWC(J) = LCWPGI(J,RANGE(TYPE,1)) SWRAD1A.391
MAXCLD(J) = LCAGI(J,RANGE(TYPE,1)) SWRAD1A.392
INDEX(J) = RANGE(TYPE,1) SWRAD1A.393
ENDDO SWRAD1A.394
DO LEVEL=RANGE(TYPE,1)+1, RANGE(TYPE,2) SWRAD1A.395
Cfpp$ Select(CONCUR) SWRAD1A.396
DO 161 J=1, NLIT SWRAD1A.397
TOTCWC(J) = TOTCWC(J) + LCWPGI(J,LEVEL) SWRAD1A.398
IF ( MAXCLD(J) .LT. LCAGI(J,LEVEL) ) THEN SWRAD1A.399
MAXCLD(J) = LCAGI(J,LEVEL) SWRAD1A.400
INDEX(J) = LEVEL SWRAD1A.401
ENDIF SWRAD1A.402
161 CONTINUE ! Next J SWRAD1A.403
ENDDO ! Next LEVEL SWRAD1A.404
C SWRAD1A.405
CL ! and use it to set the values in the array passed to SWMAST: SWRAD1A.406
C SWRAD1A.407
C ! We have the level of maximum cover for each type in the input SWRAD1A.408
C ! data, which will be the only one left non-zero. Its CWC is SWRAD1A.409
C ! set to the sum of the CWC in all the levels of that "type" SWRAD1A.410
C ! (this sum being done on the grid-box means, which will then SWRAD1A.411
C ! be converted to an in-cloud value using the selected SWRAD1A.412
C ! (maximum) cloud amount). The other levels' CWC and the rE SWRAD1A.413
C ! are not altered. SWRAD1A.414
DO LEVEL=RANGE(TYPE,1), RANGE(TYPE,2) SWRAD1A.415
Cfpp$ Select(CONCUR) SWRAD1A.416
DO 162 J=1, NLIT SWRAD1A.417
IF ( LEVEL .EQ. INDEX(J) ) THEN SWRAD1A.418
IF ( LCAGI(J,LEVEL) .GT. 0. ) SWRAD1A.419
& TOTCWC(J) = TOTCWC(J) / LCAGI(J,LEVEL) SWRAD1A.420
LCWPGI(J,LEVEL) = TOTCWC(J) SWRAD1A.421
IF (MICRO) CWPAJGI(J,LEVEL) = LCWPGI(J,LEVEL) AAJ1F304.151
ELSE SWRAD1A.422
LCAGI(J,LEVEL) = 0. SWRAD1A.423
IF (MICRO) CWPAJGI(J,LEVEL) = 0.0 AAJ1F304.152
ENDIF SWRAD1A.424
162 CONTINUE ! Next J SWRAD1A.425
ENDDO ! Next LEVEL SWRAD1A.426
ENDDO ! Next TYPE SWRAD1A.427
C SWRAD1A.428
C ! If wanted repeat the reduction-to-three-cloud-layers, but now SWRAD1A.429
C ! for all points & the other way up, for the diagnostic LCA3L. SWRAD1A.430
C ! This must be done if this diagnostic is wanted in its own right SWRAD1A.431
C ! or if TCASW is, as the latter is calculated from it. SWRAD1A.432
C ! (The loop over TYPE is still from the top down, but the loops WI250593.5
C ! over LEVEL are now from the bottom up, to match how the clouds WI250593.6
C ! are input and the output has to be output.) WI250593.7
C SWRAD1A.433
IF ( LCA3ON .OR. TCASWO ) THEN SWRAD1A.434
DO TYPE=1, 3 SWRAD1A.435
FSTLEV = NCLDS + 1 - RANGE(TYPE,2) WI250593.8
LSTLEV = NCLDS + 1 - RANGE(TYPE,1) WI250593.9
Cfpp$ Select(CONCUR) SWRAD1A.438
DO J=1, NDO SWRAD1A.439
MAXCLD(J) = LCAIN(J,FSTLEV) SWRAD1A.440
INDEX(J) = FSTLEV SWRAD1A.441
ENDDO SWRAD1A.442
DO LEVEL=FSTLEV+1, LSTLEV SWRAD1A.443
Cfpp$ Select(CONCUR) SWRAD1A.444
DO 163 J=1, NDO SWRAD1A.445
IF ( MAXCLD(J) .LT. LCAIN(J,LEVEL) ) THEN SWRAD1A.446
MAXCLD(J) = LCAIN(J,LEVEL) SWRAD1A.447
INDEX(J) = LEVEL SWRAD1A.448
ENDIF SWRAD1A.449
163 CONTINUE ! Next J SWRAD1A.450
ENDDO ! Next LEVEL SWRAD1A.451
DO LEVEL=FSTLEV, LSTLEV SWRAD1A.452
Cfpp$ Select(CONCUR) SWRAD1A.453
DO 164 J=1, NDO SWRAD1A.454
IF ( LEVEL .EQ. INDEX(J) ) THEN SWRAD1A.455
LCA3L(J,LEVEL) = MAXCLD(J) SWRAD1A.456
ELSE SWRAD1A.457
LCA3L(J,LEVEL) = 0. SWRAD1A.458
ENDIF SWRAD1A.459
164 CONTINUE ! Next J SWRAD1A.460
ENDDO ! Next LEVEL SWRAD1A.461
ENDDO ! Next TYPE SWRAD1A.462
END IF SWRAD1A.463
ENDIF ! LCLD3 AWI3F304.13
C AAJ1F304.153
IF (MICRO) THEN AAJ1F304.154
AAJ1F304.155
DO II=1,NCLDS AAJ1F304.156
DO JJ=1,NLIT AAJ1F304.157
L1AJ=LCAGI(JJ,II) AAJ1F304.158
IF (L1AJ .GT. 0.0) THEN AAJ1F304.159
TAU=(1.5*CWPAJGI(JJ,II)/(1000.0*LRE(JJ,II)))*L1AJ AAJ1F304.160
ELSE AAJ1F304.161
TAU=0.0 AAJ1F304.162
END IF AAJ1F304.163
IF (TAU .LT. 5.0) L1AJ = 0.0 AAJ1F304.164
IF (LREFFO) THEN AAJ1F304.165
LREFF(LIST(JJ),NCLDS+1-II) = LAYERE(JJ,II)*L1AJ*1.0E06 AAJ1F304.166
END IF AAJ1F304.167
IF (LRAMTO) THEN AAJ1F304.168
LRAMT(LIST(JJ),NCLDS+1-II) = L1AJ * 1.0E06 AAJ1F304.169
END IF AAJ1F304.170
IF (CWPAJON) THEN AAJ1F304.171
CWPAJ(LIST(JJ),NCLDS+1-II) = CWPAJGI(JJ,II) * L1AJ AAJ1F304.172
END IF AAJ1F304.173
ENDDO AAJ1F304.174
ENDDO AAJ1F304.175
AAJ1F304.176
END IF AAJ1F304.177
C SWRAD1A.465
CL ! Gathering the clear-sky surface albedos, multiple copies are SWRAD1A.466
CL ! needed as P234 code expects band-dependent ones, which P233 SWRAD1A.467
CL ! does not yet produce. SWRAD1A.468
DO 171 DIRDIF=1, 2 SWRAD1A.469
Cfpp$ Select(CONCUR) SWRAD1A.470
DO 17 J=1, NLIT SWRAD1A.471
SAOSGI(J,1,DIRDIF) = SAOSIN(LIST(J),DIRDIF) SWRAD1A.472
SAGI(J,1,DIRDIF) = SALIIN(LIST(J)) SWRAD1A.473
IF ( .NOT. LAND(LIST(J)) ) SWRAD1A.474
& SAGI(J,1,DIRDIF) = SAGI(J,1,DIRDIF) * AICE(LIST(J)) + SWRAD1A.475
& SAOSGI(J,1,DIRDIF) * ( 1.-AICE(LIST(J)) ) SWRAD1A.476
17 CONTINUE SWRAD1A.477
DO 171 BAND=2, NBANDS SWRAD1A.478
Cfpp$ Select(CONCUR) SWRAD1A.479
DO 171 J=1, NLIT SWRAD1A.480
SAGI(J,BAND,DIRDIF) = SAGI(J,1,DIRDIF) SWRAD1A.481
SAOSGI(J,BAND,DIRDIF) = SAOSGI(J,1,DIRDIF) SWRAD1A.482
171 CONTINUE SWRAD1A.483
C SWRAD1A.484
C ! Diagnose cloud-if-sunlit if wanted: SWRAD1A.485
C SWRAD1A.486
IF ( CCASWO ) THEN SWRAD1A.487
DO J=1, NDO SWRAD1A.488
CCASW(J) = 0.0 SWRAD1A.489
END DO SWRAD1A.490
CDir$ IVDep AWI1F304.2
Cfpp$ NoConcur L AWI1F304.3
DO J=1, NLIT SWRAD1A.491
CCASW(LIST(J)) = CCAGI(J) SWRAD1A.492
END DO SWRAD1A.493
END IF SWRAD1A.494
IF ( LCASWO ) THEN SWRAD1A.495
DO LEVEL=1, NCLDS SWRAD1A.496
Cfpp$ Select(Concur) AWI1F304.4
DO J=1, NDO SWRAD1A.497
LCASW(J,LEVEL) = 0.0 SWRAD1A.498
END DO SWRAD1A.499
CDir$ IVDep AWI1F304.5
Cfpp$ NoConcur L AWI1F304.6
DO J=1, NLIT SWRAD1A.500
LCASW(LIST(J),LEVEL) = LCAGI(J,NCLDS+1-LEVEL) SWRAD1A.501
END DO SWRAD1A.502
END DO SWRAD1A.503
END IF SWRAD1A.504
C SWRAD1A.505
CL ! Set NNIGHT, the number of night points to be treated by this SWRAD1A.506
CL ! CALL to SWRAD SWRAD1A.507
NNIGHT=NDO-NLIT SWRAD1A.508
C SWRAD1A.509
CL SWRAD1A.510
CL ! Section 2 - CALL SWMAST SWRAD1A.511
CL ~~~~~~~~~ SWRAD1A.512
CALL SWMAST (H2OGI, CO2, O3GI, PSTGI, ABGI, BBGI, LCAGI, LCWPGI, SWRAD1A.513
& LRE, CCAGI, CCWPGI, CRE, CCBGI, CCTGI, COSZGI, SWRAD1A.514
& SAGI, SAOSGI, LUT, SWRAD1A.515
& CSOSDI(1+NNIGHT), CSOSON, NSSB1(1+NNIGHT), NSS1ON, AJS1F401.1382
& TDSS(1+NNIGHT), TDSSON, SWRAD1A.517
& CSSSD(1+NNIGHT), CSSSDO, CSSSU(1+NNIGHT), CSSSUO, SWRAD1A.518
& LCAAR(1+NNIGHT,1), LCAARO, LCAARL, LCAARB, SWRAD1A.519
& LCAAF(1+NNIGHT,1), LCAAFO, LCAAFL, LCAAFB, SWRAD1A.520
& CCAAR(1+NNIGHT,1), CCAARO, CCAARB, SWRAD1A.521
& CCAAF(1+NNIGHT,1), CCAAFO, CCAAFB, SWRAD1A.522
& NLIT, NLEVS, NCLDS, GSS1F402.31
& NWET, NOZONE, NLIT, L1, SWSEA(1+NNIGHT), SWOUT(1+NNIGHT,1) ) SWRAD1A.526
C SWRAD1A.527
C SWRAD1A.528
CL ! Also, zero areas of SWOUT & SWSEA that will not be set by SWMAST SWRAD1A.529
C SWRAD1A.530
C ! (They are multiplied, here or in the control routines, SWRAD1A.531
C ! by the mean cosz for each physics timestep, i.e. zero at night SWRAD1A.532
C ! points, but this would fail if a word were not a valid real.) SWRAD1A.533
C ! SWRAD1A.534
IF ( NDO.GT.NLIT ) THEN SWRAD1A.535
DO 20 LEVEL=1, NLEVS+2 AJS1F401.1383
Cfpp$ Select(CONCUR) SWRAD1A.537
DO 20 J=1, NNIGHT SWRAD1A.538
SWOUT(J,LEVEL) = 0. SWRAD1A.539
20 CONTINUE SWRAD1A.540
DO J=1, NNIGHT SWRAD1A.541
SWSEA(J) = 0. SWRAD1A.542
ENDDO SWRAD1A.543
ENDIF SWRAD1A.544
C SWRAD1A.545
C SWRAD1A.546
CL ! Section 3 - convert normalized net downward flux to atmospheric SWRAD1A.547
CL ! ~~~~~~~~~ heating rates and surface actual net downward flux SWRAD1A.548
C SWRAD1A.549
CL ! Set up normalized-to-actual flux conversion factors: SWRAD1A.550
CL ! the incoming insolation at the top of the atmosphere SWRAD1A.551
C SWRAD1A.552
NSI = SC * SCS SWRAD1A.553
DO 31 J=1, NDO SWRAD1A.554
IITOA(J) = NSI * COSZIN(J) * LIT(J) SWRAD1A.555
31 CONTINUE SWRAD1A.556
C SWRAD1A.557
CL ! and set COSZGI to the same for daylit points SWRAD1A.558
C SWRAD1A.559
DO 32 J=1, NLIT SWRAD1A.560
COSZGI(J) = IITOA(LIST(J)) SWRAD1A.561
32 CONTINUE SWRAD1A.562
C SWRAD1A.563
CL ! Fill NTSWIN: SWRAD1A.564
C SWRAD1A.565
DO J=1, NDO SWRAD1A.566
NTSWIN(J) = 0. SWRAD1A.567
ENDDO SWRAD1A.568
C SWRAD1A.569
CDir$ IVDep AWI1F304.7
Cfpp$ NoConcur L AWI1F304.8
DO 323 J=1, NLIT SWRAD1A.570
NTSWIN(LIST(J)) = COSZGI(J) * SWOUT(J+NNIGHT,1) SWRAD1A.571
323 CONTINUE SWRAD1A.572
C SWRAD1A.573
C ! Before flux-differencing, diagnose outgoing solar if wanted : SWRAD1A.574
C SWRAD1A.575
IF ( OSON ) THEN SWRAD1A.576
DO J=1, NDO SWRAD1A.577
OSDIA(J) = 0. SWRAD1A.578
ENDDO SWRAD1A.579
CDir$ IVDep AWI1F304.9
Cfpp$ NoConcur L AWI1F304.10
DO J=1, NLIT SWRAD1A.580
OSDIA(LIST(J)) = COSZGI(J) * ( 1. - SWOUT(J+NNIGHT,1) ) SWRAD1A.581
ENDDO SWRAD1A.582
ENDIF SWRAD1A.583
CL SWRAD1A.584
CL ! and if CSOSDI is wanted, scatter it back and convert it from SWRAD1A.585
CL ! normalized to actual flux: SWRAD1A.586
CL SWRAD1A.587
IF ( CSOSON ) THEN SWRAD1A.588
DO J=1, NNIGHT SWRAD1A.589
CSOSDI(J) = 0. SWRAD1A.590
ENDDO SWRAD1A.591
CDir$ IVDep SWRAD1A.592
Cfpp$ NoConcur L SWRAD1A.593
DO J=1, NLIT SWRAD1A.594
CSOSDI(LIST(J)) = CSOSDI(J+NNIGHT) SWRAD1A.595
ENDDO SWRAD1A.596
DO J=1, NDO SWRAD1A.597
CSOSDI(J) = IITOA(J) * CSOSDI(J) SWRAD1A.598
ENDDO SWRAD1A.599
ENDIF SWRAD1A.600
C SWRAD1A.601
CL ! Scatter NSSB1 back and convert from normalized to actual flux AJS1F401.1384
C ! (including multiplication by open-sea fraction), and set to SWRAD1A.603
C ! zero over land: SWRAD1A.604
C SWRAD1A.605
IF( NSS1ON) THEN AJS1F401.1385
DO J=1, NNIGHT SWRAD1A.607
NSSB1(J) = 0. AJS1F401.1386
ENDDO SWRAD1A.609
CDir$ IVDep AJS1F401.1387
Cfpp$ NoConcur L AJS1F401.1388
DO J=1, NLIT SWRAD1A.612
NSSB1(LIST(J)) = NSSB1(J+NNIGHT) AJS1F401.1389
ENDDO SWRAD1A.614
C Set NSSB1 over both land and sea surface AJS1F401.1390
DO J=1, NDO SWRAD1A.615
IF ( LAND(J) ) THEN SWRAD1A.616
NSSB1(J) = IITOA(J) * NSSB1(J) AJS1F401.1391
ELSE AJS1F401.1392
NSSB1(J) = IITOA(J) * ( 1. - AICE(J) ) * NSSB1(J) AJS1F401.1393
ENDIF SWRAD1A.620
AJS1F401.1394
C Find total downward SW flux in band 1 AJS1F401.1395
TDSSB1(J) = NSSB1(J) / (1.0 - SALIIN(J)) AJS1F401.1396
C (Albedo should never equal 1.0) AJS1F401.1397
C Store TDSSB1 without zenith angle adjustment in SWOUT AJS1F401.1398
IF(IITOA(J).NE.0.0) THEN AJS1F401.1399
SWOUT(J,NLEVS+2) = TDSSB1(J) / (COSZIN(J) * LIT(J)) AJS1F401.1400
ENDIF AJS1F401.1401
ENDDO ! NDO AJS1F401.1402
AJS1F401.1403
ELSE ! NSS1ON is false AJS1F401.1404
C Photosynthetically active radiation not required, but initialise to AJS1F401.1405
C zero to avoid possible problems accessing uninitialised data later. AJS1F401.1406
DO J=1,NDO AJS1F401.1407
SWOUT(J,NLEVS+2) = 0.0 AJS1F401.1408
ENDDO ! NDO AJS1F401.1409
AJS1F401.1410
ENDIF ! NSS1ON AJS1F401.1411
C SWRAD1A.623
CL ! Scatter TDSS back and convert from normalized to actual flux: SWRAD1A.624
C SWRAD1A.625
IF ( TDSSON ) THEN SWRAD1A.626
DO J=1, NNIGHT SWRAD1A.627
TDSS(J) = 0. SWRAD1A.628
ENDDO SWRAD1A.629
CDir$ IVDep SWRAD1A.630
Cfpp$ NoConcur L SWRAD1A.631
DO J=1, NLIT SWRAD1A.632
TDSS(LIST(J)) = TDSS(J+NNIGHT) SWRAD1A.633
ENDDO SWRAD1A.634
DO J=1, NDO SWRAD1A.635
TDSS(J) = IITOA(J) * TDSS(J) SWRAD1A.636
ENDDO SWRAD1A.637
ENDIF SWRAD1A.638
C SWRAD1A.639
CL ! And the same for CSSSD and CSSSU: SWRAD1A.640
C SWRAD1A.641
IF ( CSSSDO ) THEN SWRAD1A.642
DO J=1, NNIGHT SWRAD1A.643
CSSSD(J) = 0. SWRAD1A.644
ENDDO SWRAD1A.645
CDir$ IVDep SWRAD1A.646
Cfpp$ NoConcur L SWRAD1A.647
DO J=1, NLIT SWRAD1A.648
CSSSD(LIST(J)) = CSSSD(J+NNIGHT) SWRAD1A.649
ENDDO SWRAD1A.650
DO J=1, NDO SWRAD1A.651
CSSSD(J) = IITOA(J) * CSSSD(J) SWRAD1A.652
ENDDO SWRAD1A.653
ENDIF SWRAD1A.654
IF ( CSSSUO ) THEN SWRAD1A.655
DO J=1, NNIGHT SWRAD1A.656
CSSSU(J) = 0. SWRAD1A.657
ENDDO SWRAD1A.658
CDir$ IVDep SWRAD1A.659
Cfpp$ NoConcur L SWRAD1A.660
DO J=1, NLIT SWRAD1A.661
CSSSU(LIST(J)) = CSSSU(J+NNIGHT) SWRAD1A.662
ENDDO SWRAD1A.663
DO J=1, NDO SWRAD1A.664
CSSSU(J) = IITOA(J) * CSSSU(J) SWRAD1A.665
ENDDO SWRAD1A.666
ENDIF SWRAD1A.667
C SWRAD1A.668
CL ! and cloud albedo diagnostics: SWRAD1A.669
C SWRAD1A.670
IF ( LCAARO ) THEN SWRAD1A.671
OFFSET = 1 SWRAD1A.672
DO 338 BAND=1, NBANDS SWRAD1A.673
DO 338 LEVEL=1, NCLDS SWRAD1A.674
IF ( LCAARL(LEVEL) .AND. LCAARB(BAND) ) THEN SWRAD1A.675
CDir$ IVDep SWRAD1A.676
Cfpp$ NoConcur L SWRAD1A.677
DO J=1, NLIT SWRAD1A.678
LCAAR(LIST(J),OFFSET) = LCAAR(J+NNIGHT,OFFSET) SWRAD1A.679
ENDDO SWRAD1A.680
CDir$ IVDep SWRAD1A.681
DO J=1, NDO SWRAD1A.682
IF ( LIT(J) .EQ. 0. ) LCAAR(J,OFFSET) = 0. SWRAD1A.683
ENDDO SWRAD1A.684
OFFSET = OFFSET + 1 SWRAD1A.685
ENDIF SWRAD1A.686
338 CONTINUE SWRAD1A.687
ENDIF SWRAD1A.688
IF ( LCAAFO ) THEN SWRAD1A.689
OFFSET = 1 SWRAD1A.690
DO 337 BAND=1, NBANDS SWRAD1A.691
DO 337 LEVEL=1, NCLDS SWRAD1A.692
IF ( LCAAFL(LEVEL) .AND. LCAAFB(BAND) ) THEN SWRAD1A.693
CDir$ IVDep SWRAD1A.694
Cfpp$ NoConcur L SWRAD1A.695
DO J=1, NLIT SWRAD1A.696
LCAAF(LIST(J),OFFSET) = LCAAF(J+NNIGHT,OFFSET) SWRAD1A.697
ENDDO SWRAD1A.698
CDir$ IVDep SWRAD1A.699
DO J=1, NDO SWRAD1A.700
IF ( LIT(J) .EQ. 0. ) LCAAF(J,OFFSET) = 0. SWRAD1A.701
ENDDO SWRAD1A.702
OFFSET = OFFSET + 1 SWRAD1A.703
ENDIF SWRAD1A.704
337 CONTINUE SWRAD1A.705
ENDIF SWRAD1A.706
IF ( CCAARO ) THEN SWRAD1A.707
OFFSET = 1 SWRAD1A.708
DO 336 BAND=1, NBANDS SWRAD1A.709
IF ( CCAARB(BAND) ) THEN SWRAD1A.710
CDir$ IVDep SWRAD1A.711
Cfpp$ NoConcur L SWRAD1A.712
DO J=1, NLIT SWRAD1A.713
CCAAR(LIST(J),OFFSET) = CCAAR(J+NNIGHT,OFFSET) SWRAD1A.714
ENDDO SWRAD1A.715
CDir$ IVDep SWRAD1A.716
DO J=1, NDO SWRAD1A.717
IF ( LIT(J) .EQ. 0. ) CCAAR(J,OFFSET) = 0. SWRAD1A.718
ENDDO SWRAD1A.719
OFFSET = OFFSET + 1 SWRAD1A.720
ENDIF SWRAD1A.721
336 CONTINUE SWRAD1A.722
ENDIF SWRAD1A.723
IF ( CCAAFO ) THEN SWRAD1A.724
OFFSET = 1 SWRAD1A.725
DO 335 BAND=1, NBANDS SWRAD1A.726
IF ( CCAAFB(BAND) ) THEN SWRAD1A.727
CDir$ IVDep SWRAD1A.728
Cfpp$ NoConcur L SWRAD1A.729
DO J=1, NLIT SWRAD1A.730
CCAAF(LIST(J),OFFSET) = CCAAF(J+NNIGHT,OFFSET) SWRAD1A.731
ENDDO SWRAD1A.732
CDir$ IVDep SWRAD1A.733
DO J=1, NDO SWRAD1A.734
IF ( LIT(J) .EQ. 0. ) CCAAF(J,OFFSET) = 0. SWRAD1A.735
ENDDO SWRAD1A.736
OFFSET = OFFSET + 1 SWRAD1A.737
ENDIF SWRAD1A.738
335 CONTINUE SWRAD1A.739
ENDIF SWRAD1A.740
C SWRAD1A.741
CL ! Invert SWOUT and scatter it and SWSEA back SWRAD1A.742
C SWRAD1A.743
CDir$ IVDep SWRAD1A.744
Cfpp$ NoConcur L SWRAD1A.745
DO 33 J=1, NLIT SWRAD1A.746
SWSEA(LIST(J)) = SWSEA(J+NNIGHT) SWRAD1A.747
33 CONTINUE SWRAD1A.748
NLP1B2=(NLEVS+1)/2 SWRAD1A.749
CIf this were NLEVS/2+1, could omit special case (do (twice) as general) SWRAD1A.750
DO 34 LEVEL=1, NLP1B2 SWRAD1A.751
CDir$ IVDep SWRAD1A.752
Cfpp$ NoConcur L SWRAD1A.753
DO 34 J=1, NLIT SWRAD1A.754
TEMPOR = SWOUT(J+NNIGHT,LEVEL) SWRAD1A.755
SWOUT(LIST(J),LEVEL) = SWOUT(J+NNIGHT,NLEVS+2-LEVEL) SWRAD1A.756
SWOUT(LIST(J),NLEVS+2-LEVEL) = TEMPOR SWRAD1A.757
34 CONTINUE SWRAD1A.758
IF ( NLEVS/2*2 .EQ. NLEVS ) THEN ! Middle level: scatter only SWRAD1A.759
CDir$ IVDep SWRAD1A.760
Cfpp$ NoConcur L SWRAD1A.761
DO 35 J=1, NLIT SWRAD1A.762
SWOUT(LIST(J),LEVEL) = SWOUT(J+NNIGHT,LEVEL) SWRAD1A.763
35 CONTINUE SWRAD1A.764
ENDIF SWRAD1A.765
C SWRAD1A.766
CL ! If wanted, diagnose total cloud amount as seen by the SW: SWRAD1A.767
C SWRAD1A.768
IF ( TCASWO ) THEN AWI3F304.14
IF ( LCLD3 ) THEN AWI3F304.15
CALL SWDTCA (LCA3L, CCAIN, NCLDS, L1, NDO, TCASW) AWI3F304.16
ELSE AWI3F304.17
CALL SWDTCA (LCAIN, CCAIN, NCLDS, L1, NDO, TCASW) AWI3F304.18
ENDIF AWI3F304.19
ENDIF AWI3F304.20
C SWRAD1A.775
CL ! Convert fluxes to increments (Eq 1.1), and also put NSI in SWRAD1A.776
C ! - but omit cosz term (we could multiply by IITOA to get values SWRAD1A.777
C ! averaged over the whole SW timestep, but this is omitted so SWRAD1A.778
C ! that the control code can multiply by the correct mean cosz SWRAD1A.779
C ! for each physics timestep). Also zero the heating rates for AWI1F400.15
C ! night points in the later part of the scattered-back vector AWI1F400.16
C ! - these should be multiplied by cosz=0 before being added in, AWI1F400.17
C ! but there is the possibility of rounding-error-sized cosz AWI1F400.18
C ! (from when the sun sets just as the timestep starts, or rises AWI1F400.19
C ! just as it finishes) not being calculated consistently on some AWI1F400.20
C ! machines, so it is safest to zero them in case, rather than AWI1F400.21
C ! leave in the values for some day point which would then be AWI1F400.22
C ! added in multiplied by a (very small) cosz to give (very AWI1F400.23
C ! small) spurious and batching-dependent heating. AWI1F400.24
C SWRAD1A.785
DO 37 LEVEL=NLEVS, 1, -1 SWRAD1A.786
DACON1 = ( ABIN(LEVEL) - ABIN(LEVEL+1) ) * CPBYG / ( PTS * NSI ) SWRAD1A.787
DBCON1 = ( BBIN(LEVEL) - BBIN(LEVEL+1) ) * CPBYG / ( PTS * NSI ) SWRAD1A.788
DO 38 J=1, NDO SWRAD1A.789
SWOUT(J,LEVEL+1) = ( SWOUT(J,LEVEL+1) - SWOUT(J,LEVEL) ) SWRAD1A.790
& / ( DACON1 + PSTIN(J) * DBCON1 ) SWRAD1A.791
38 CONTINUE SWRAD1A.792
DO J=NNIGHT+1, NDO AWI1F400.25
IF ( IITOA(J) .EQ. 0. ) SWOUT(J,LEVEL+1) = 0. AWI1F400.26
ENDDO AWI1F400.27
37 CONTINUE SWRAD1A.793
C SWRAD1A.794
CL ! Finally, subtract the open-sea contribution from the total SWRAD1A.795
CL ! net downward surface flux to leave the land-and-sea-ice SWRAD1A.796
CL ! contribution, and convert both from normalized fluxes to SWRAD1A.797
CL ! dimensioned ones - they did not get multiplied by NSI as the SWRAD1A.798
CL ! atmospheric heating rates have just been. The term to be used SWRAD1A.799
CL ! over land or sea-ice is not multiplied by the cos(solar zenith SWRAD1A.800
CL ! angle) term because this will be done for each physics SWRAD1A.801
CL ! timestep in the control routines (though again it is set to AWI1F400.28
CL ! zero at night points), but SWSEA and NSSB1 are. AJS1F401.1412
C SWRAD1A.803
DO 39 J=1, NDO SWRAD1A.804
IF ( LAND(J) ) THEN SWRAD1A.805
SWSEA(J) = 0. SWRAD1A.806
ELSE SWRAD1A.807
SWSEA(J) = SWSEA(J) * ( 1.-AICE(J) ) SWRAD1A.808
SWOUT(J,1) = SWOUT(J,1) - SWSEA(J) SWRAD1A.809
SWSEA(J) = IITOA(J) * SWSEA(J) SWRAD1A.810
ENDIF SWRAD1A.811
SWOUT(J,1) = SWOUT(J,1) * NSI SWRAD1A.812
39 CONTINUE SWRAD1A.813
DO J=NNIGHT+1, NDO AWI1F400.30
IF ( IITOA(J) .EQ. 0. ) SWOUT(J,1) = 0. AWI1F400.31
ENDDO AWI1F400.32
C SWRAD1A.814
RETURN SWRAD1A.815
END SWRAD1A.816
*ENDIF DEF,A01_1A,OR,DEF,A01_1B,OR,DEF,A01_2A SWRAD1A.817