SUBROUTINE R2_SWRAD(IERR 2,26SWRAD3A.24
! Mixing Ratios SWRAD3A.25
& , H2O, CO2, O3, O2_MIX_RATIO ADB2F404.1506
& , CO2_DIM1, CO2_DIM2, CO2_3D, L_CO2_3D ACN2F405.90
! Pressure Fields SWRAD3A.27
& , PSTAR, AB, BB, AC, BC SWRAD3A.28
! Temperatures SWRAD3A.29
& , TAC SWRAD3A.30
! Options for treating clouds ADB1F402.884
& , L_GLOBAL_CLOUD_TOP, GLOBAL_CLOUD_TOP ADB1F402.885
! Stratiform Cloud Fields SWRAD3A.31
& , L_CLOUD_WATER_PARTITION AYY1F404.364
& , LCA_AREA, LCA_BULK, LCCWC1, LCCWC2 ASK1F405.277
! Convective Cloud Fields SWRAD3A.33
& , CCA, CCCWP, CCB, CCT, L_3D_CCA AJX0F404.31
! Surface Fields SWRAD3A.35
& , SAL_VIS, SAL_NIR ARE2F404.239
& , LAND_ICE_ALBEDO, OPEN_SEA_ALBEDO, ICE_FRACTION, LAND SWRAD3A.36
& , LYING_SNOW ADB1F402.698
! Prognostic snow albedo flag ARE2F404.240
& , L_SNOW_ALBEDO, SAL_DIM ARE2F404.241
! Solar Fields SWRAD3A.37
& , COSZIN, LIT, LIST, SCS SWRAD3A.38
! Aerosol Fields SWRAD3A.39
& , L_CLIMAT_AEROSOL, N_LEVELS_BL ADB1F402.699
& , L_USE_SULPC_DIRECT, L_USE_SULPC_INDIRECT ADB1F401.1027
& , SULP_DIM1, SULP_DIM2 ADB1F402.700
& , ACCUM_SULPHATE, AITKEN_SULPHATE, DISS_SULPHATE ADB2F404.1507
&,L_USE_SOOT_DIRECT, SOOT_DIM1, SOOT_DIM2, FRESH_SOOT, AGED_SOOT ALR3F405.112
! Level of tropopause ADB1F402.701
& , TRINDX ADB1F402.702
! Spectrum SWRAD3A.41
*CALL SWSARG3A 
ADB2F404.1508
! Algorithmic options ADB2F404.1509
*CALL SWCARG3A ADB2F404.1510
& , PTS ADB2F404.1511
! General Diagnostics SWRAD3A.43
& , SOLAR_OUT_TOA, L_SOLAR_OUT_TOA SWRAD3A.44
& , SOLAR_OUT_CLEAR, L_SOLAR_OUT_CLEAR SWRAD3A.45
& , FLUX_BELOW_690NM_SURF, L_FLUX_BELOW_690NM_SURF SWRAD3A.46
& , SURFACE_DOWN_FLUX, L_SURFACE_DOWN_FLUX SWRAD3A.47
& , SURF_DOWN_CLR, L_SURF_DOWN_CLR SWRAD3A.48
& , SURF_UP_CLR, L_SURF_UP_CLR SWRAD3A.49
& , LAYER_CLOUD_LIT, L_LAYER_CLOUD_LIT SWRAD3A.50
& , CONV_CLOUD_LIT, L_CONV_CLOUD_LIT SWRAD3A.51
& , TOTAL_CLOUD_COVER, L_TOTAL_CLOUD_COVER SWRAD3A.52
& , CLEAR_HR, L_CLEAR_HR SWRAD3A.53
& , NET_FLUX_TROP, L_NET_FLUX_TROP ADB2F404.1512
& , UP_FLUX_TROP, L_UP_FLUX_TROP ADB2F404.1513
! Microphysical Flag SWRAD3A.54
& , L_MICROPHYSICS SWRAD3A.55
! Microphysical Diagnostics SWRAD3A.56
& , RE_CONV, RE_CONV_FLAG, RE_STRAT, RE_STRAT_FLAG SWRAD3A.57
& , WGT_CONV, WGT_CONV_FLAG, WGT_STRAT, WGT_STRAT_FLAG SWRAD3A.58
& , LWP_STRAT, LWP_STRAT_FLAG SWRAD3A.59
& , WEIGHTED_RE, WEIGHTED_RE_FLAG AAJ3F404.10
& , SUM_WEIGHT_RE, SUM_WEIGHT_RE_FLAG AAJ3F404.11
& , NTOT_DIAG, NTOT_DIAG_FLAG AAJ3F404.12
& , STRAT_LWC_DIAG, STRAT_LWC_DIAG_FLAG AAJ3F404.13
& , SO4_CCN_DIAG, SO4_CCN_DIAG_FLAG AAJ3F404.14
& , COND_SAMP_WGT, COND_SAMP_WGT_FLAG AAJ3F404.15
! Physical Dimensions SWRAD3A.60
& , NLIT SWRAD3A.61
& , N_PROFILE, NLEVS, NCLDS SWRAD3A.62
& , NWET, NOZONE SWRAD3A.63
& , NPD_FIELD, NPD_PROFILE, NPD_LAYER, NPD_COLUMN SWRAD3A.64
& , N_CCA_LEV AJX0F404.32
! Working Dimensions for Diagnostics ADB2F404.1514
& , NPDWD_CL_PROFILE ADB2F404.1515
! Output SWRAD3A.74
& , NETSW, SWSEA, SWOUT SWRAD3A.75
& ) SWRAD3A.76
! SWRAD3A.77
! SWRAD3A.78
! SWRAD3A.79
IMPLICIT NONE SWRAD3A.80
! SWRAD3A.81
! SWRAD3A.82
! SWRAD3A.83
! COMDECKS INCLUDED SWRAD3A.84
*CALL C_R_CP SWRAD3A.85
*CALL C_G SWRAD3A.86
*CALL SWSC SWRAD3A.87
! INTERNAL DIMENSIONS OF THE CODE SWRAD3A.88
*CALL DIMFIX3A SWRAD3A.89
! SPECTRAL REGIONS SWRAD3A.93
*CALL SPCRG3A SWRAD3A.94
! ANGULAR INTEGRATION SWRAD3A.95
*CALL ANGINT3A SWRAD3A.96
! TREATMENT OF SCATTERING SWRAD3A.97
*CALL SCTMTH3A SWRAD3A.98
! OPTIONS TO THE CODE ALTERABLE IN THE UM. ADB2F404.1516
*CALL SWOPT3A ADB2F404.1517
! OPTIONS TO THE CODE FIXED IN THE UM. ADB2F404.1518
*CALL SWFIX3A SWRAD3A.100
! NUMERICAL PRECISION SWRAD3A.102
*CALL PRMCH3A SWRAD3A.103
! SOLVERS SWRAD3A.104
*CALL SOLVER3A SWRAD3A.105
! ERROR FLAGS SWRAD3A.106
*CALL ERROR3A SWRAD3A.107
! UNIT NUMBERS FOR PRINTED OUTPUT ADB2F404.1519
*CALL STDIO3A ADB2F404.1520
! SWRAD3A.108
! SWRAD3A.109
! DUMMY ARGUMENTS SWRAD3A.110
! SWRAD3A.111
INTEGER !, INTENT(OUT) SWRAD3A.112
& IERR SWRAD3A.113
! ERROR FLAG SWRAD3A.114
! SWRAD3A.115
! DIMENSIONS OF ARRAYS: SWRAD3A.116
INTEGER !, INTENT(IN) SWRAD3A.117
& NPD_FIELD SWRAD3A.121
! FIELD SIZE IN CALLING PROGRAM SWRAD3A.122
& , NPD_PROFILE SWRAD3A.123
! SIZE OF ARRAY OF PROFILES SWRAD3A.124
& , NPD_LAYER SWRAD3A.125
! ARRAY SIZES FOR LAYERS SWRAD3A.126
& , NPD_COLUMN SWRAD3A.127
! NUMBER OF COLUMNS PER POINT SWRAD3A.128
! SWRAD3A.129
! DIMENSIONS FOR DIAGNOSTIC WORKSPACE ADB2F404.1521
INTEGER !, INTENT(IN) SWRAD3A.131
& NPDWD_CL_PROFILE ADB2F404.1522
! NUMBER OF PROFILES ALLOWED IN WORKSPACE FOR ADB2F404.1523
! CLOUD DIAGNOSTICS ADB2F404.1524
! SWRAD3A.164
! ACTUAL SIZES USED: SWRAD3A.165
INTEGER !, INTENT(IN) SWRAD3A.166
& N_PROFILE SWRAD3A.167
! NUMBER OF PROFILES SWRAD3A.168
& , NWET SWRAD3A.169
! NUMBER OF WET LEVELS SWRAD3A.170
& , NOZONE SWRAD3A.171
! NUMBER OF LEVELS WITH OZONE SWRAD3A.172
& , NLEVS SWRAD3A.173
! NUMBER OF ATMOSPHERIC LAYERS SWRAD3A.174
& , NCLDS SWRAD3A.175
! NUMBER OF CLOUDY LEVELS SWRAD3A.176
& , N_LEVELS_BL ADB1F402.703
! NUMBER OF LEVELS IN THE BOUNDARY LAYER ADB1F402.704
& , N_CCA_LEV AJX0F404.33
! NUMBER OF CONVECTIVE CLOUD LEVELS AJX0F404.34
! SWRAD3A.177
! SPECTRAL DATA: ADB2F404.1525
*CALL SWSPDC3A ADB2F404.1526
! ADB2F404.1527
! SWRAD3A.178
! SWRAD3A.179
! GASEOUS MIXING RATIOS SWRAD3A.180
REAL !, INTENT(IN) SWRAD3A.181
& H2O(NPD_FIELD, NWET) SWRAD3A.182
! MASS MIXING RATIO OF WATER SWRAD3A.183
& , CO2 SWRAD3A.184
! MASS MIXING RATIO OF CO2 SWRAD3A.185
& , O3(NPD_FIELD, NOZONE) SWRAD3A.186
! MASS MIXING RATIOS OF OZONE SWRAD3A.187
& , O2_MIX_RATIO ADB2F404.1528
! MASS MIXING RATIO OF OXYGEN ADB2F404.1529
! SWRAD3A.188
! GENERAL ATMOSPHERIC PROPERTIES: SWRAD3A.189
REAL !, INTENT(IN) SWRAD3A.190
& PSTAR(NPD_FIELD) SWRAD3A.191
! SURFACE PRESSURES SWRAD3A.192
& , AB(NLEVS+1) SWRAD3A.193
! A AT BOUNDARIES OF LAYERS SWRAD3A.194
& , BB(NLEVS+1) SWRAD3A.195
! B AT BOUNDARIES OF LAYERS SWRAD3A.196
& , AC(NLEVS) SWRAD3A.197
! A AT CENTRES OF LAYERS SWRAD3A.198
& , BC(NLEVS) SWRAD3A.199
! B AT CENTRES OF LAYERS SWRAD3A.200
& , TAC(NPD_FIELD, NLEVS) SWRAD3A.201
! TEMPERATURES AT CENTRES OF LAYERS SWRAD3A.202
! SWRAD3A.203
! INCIDENT SOLAR RADIATION: SWRAD3A.204
INTEGER !, INTENT(IN) SWRAD3A.205
& NLIT SWRAD3A.206
! NUMBER OF LIT POINTS SWRAD3A.207
& , LIST(NPD_FIELD) SWRAD3A.208
! LIST OF LIT POINTS SWRAD3A.209
REAL !, INTENT(IN) SWRAD3A.210
& COSZIN(NPD_FIELD) SWRAD3A.211
! COSINES OF ZENITH ANGLE SWRAD3A.212
& , SCS SWRAD3A.213
! SCALING OF SOLAR INCIDENT FIELD SWRAD3A.214
& , LIT(NPD_FIELD) SWRAD3A.215
! FRACTION OF TIME POINT IS LIT SWRAD3A.216
! SWRAD3A.217
! MICROPHYSICAL FLAG: SWRAD3A.218
LOGICAL !, INTENT(IN) SWRAD3A.219
& L_MICROPHYSICS SWRAD3A.220
! FLAG FOR PARAMETRIZED MICROPHYSICS SWRAD3A.221
! SWRAD3A.222
! OPTIONS FOR TREATING CLOUDS ADB1F402.886
LOGICAL !, INTENT(IN) ADB1F402.887
& L_GLOBAL_CLOUD_TOP ADB1F402.888
! FLAG TO USE A GLOBAL VALUE FOR THE TOPS OF CLOUDS ADB1F402.889
! TO ENSURE REPRODUCIBLE RESULTS ADB1F402.890
INTEGER !, INTENT(IN) ADB1F402.891
& GLOBAL_CLOUD_TOP ADB1F402.892
! GLOBAL TOPMOST CLOUDY LAYER ADB1F402.893
! ADB1F402.894
! PROPERTIES OF STRATIFORM CLOUDS: SWRAD3A.223
LOGICAL !, INTENT(IN) AYY1F404.365
& L_CLOUD_WATER_PARTITION AYY1F404.366
! FLAG TO USE PROGNOSTIC CLOUD ICE CONTENTS AYY1F404.367
REAL !, INTENT(IN) SWRAD3A.224
& LCCWC1(NPD_FIELD, NCLDS+1/(NCLDS+1)) SWRAD3A.225
! NOMINAL LIQUID WATER CONTENTS SWRAD3A.226
& , LCCWC2(NPD_FIELD, NCLDS+1/(NCLDS+1)) SWRAD3A.227
! NOMINAL ICE WATER CONTENTS SWRAD3A.228
& , LCA_AREA(NPD_FIELD, NCLDS+1/(NCLDS+1)) ASK1F405.278
! AREA FRACTIONS OF LAYER CLOUDS OUTSIDE CONVECTIVE TOWERS ASK1F405.279
& , LCA_BULK(NPD_FIELD, NCLDS+1/(NCLDS+1)) ASK1F405.280
! BULK FRACTIONS OF LAYER CLOUDS OUTSIDE CONVECTIVE TOWERS ASK1F405.281
! SWRAD3A.231
! PROPERTIES OF CONVECTIVE CLOUDS: SWRAD3A.232
INTEGER !, INTENT(IN) SWRAD3A.233
& CCB(NPD_FIELD) SWRAD3A.234
! BASE OF CONVECTIVE CLOUD SWRAD3A.235
& , CCT(NPD_FIELD) SWRAD3A.236
! TOP OF CONVECTIVE CLOUD SWRAD3A.237
REAL !, INTENT(IN) SWRAD3A.238
& CCCWP(NPD_FIELD) SWRAD3A.239
! WATER PATH OF CONVECTIVE CLOUD SWRAD3A.240
& , CCA(NPD_FIELD,N_CCA_LEV) AJX0F404.35
! FRACTION OF CONVECTIVE CLOUD SWRAD3A.242
LOGICAL !, INTENT(IN) AJX0F404.36
& L_3D_CCA AJX0F404.37
! FLAG FOR 3D convective cloud amount AJX0F404.38
! SWRAD3A.243
! AEROSOLS: SWRAD3A.244
LOGICAL !, INTENT(IN) ADB1F401.1033
& L_CLIMAT_AEROSOL ADB1F402.705
! FLAG FOR CLIMATOLOGICAL AEROSOL ADB1F402.706
LOGICAL !, INTENT(IN) ADB1F402.707
& L_USE_SULPC_DIRECT ADB1F401.1034
! FLAG TO USE SULPHUR CYCLE FOR DIRECT EFFECT ADB1F401.1035
& , L_USE_SULPC_INDIRECT ADB1F401.1036
! FLAG TO USE SULPHUR CYCLE FOR INDIRECT EFFECT ADB1F401.1037
& , L_USE_SOOT_DIRECT ! USE DIRECT RAD. EFFECT OF SOOT AEROSOL ALR3F405.113
INTEGER !, INTENT(IN) ADB1F401.1038
& SULP_DIM1,SULP_DIM2 ADB1F401.1039
! DIMENSIONS FOR _SULPHATE ARRAYS, (P_FIELD,P_LEVELS or 1,1) ADB1F401.1040
& , SOOT_DIM1, SOOT_DIM2 ALR3F405.114
! DIMENSIONS FOR SOOT ARRAYS (P_FIELD,P_LEVELS or 1,1) ALR3F405.115
REAL !, INTENT(IN) SWRAD3A.245
& ACCUM_SULPHATE(SULP_DIM1, SULP_DIM2) ADB1F402.708
! MASS MIXING RATIO OF ACCUMULATION MODE AEROSOL ADB1F401.1042
& , AITKEN_SULPHATE(SULP_DIM1, SULP_DIM2) ADB1F402.709
! MASS MIXING RATIO OF AITKEN MODE AEROSOL ADB1F401.1044
& , DISS_SULPHATE(SULP_DIM1, SULP_DIM2) AYY1F404.368
! MIXING RATIO OF DISSOLVED SULPHATE AYY1F404.369
&,FRESH_SOOT(SOOT_DIM1,SOOT_DIM2),AGED_SOOT(SOOT_DIM1,SOOT_DIM2) ALR3F405.116
! SOOT MIXING RATIOS ALR3F405.117
! SWRAD3A.248
! CARBON CYCLE: ACN2F405.91
LOGICAL L_CO2_3D ! controls use of 3D co2 field ACN2F405.92
INTEGER !, INTENT(IN) ACN2F405.93
& CO2_DIM1, CO2_DIM2 ACN2F405.94
! DIMENSIONS FOR CO2 ARRAY, (P_FIELD,P_LEVELS or 1,1) ACN2F405.95
REAL !, INTENT(IN) ACN2F405.96
& CO2_3D(CO2_DIM1, CO2_DIM2) ACN2F405.97
! MASS MIXING RATIO OF CARBON DIOXIDE ACN2F405.98
! PROPERTIES OF THE SURFACE: SWRAD3A.249
LOGICAL !, INTENT(IN) SWRAD3A.250
& LAND(NPD_FIELD) SWRAD3A.251
! LAND SEA MASK SWRAD3A.252
& , L_SNOW_ALBEDO ARE2F404.242
! FLAG FOR PROGNOSTIC SNOW ALBEDO ARE2F404.243
INTEGER !, INTENT(IN) ARE2F404.244
& SAL_DIM ARE2F404.245
! DIMENSION FOR SAL_VIS AND SAL_NIR ARE2F404.246
REAL !, INTENT(IN) SWRAD3A.253
& ICE_FRACTION(NPD_FIELD) SWRAD3A.254
! SEA ICE FRACTION SWRAD3A.255
& , SAL_VIS(SAL_DIM,2) ARE2F404.247
! SURFACE VISIBLE ALBEDO FIELD ARE2F404.248
& , SAL_NIR(SAL_DIM,2) ARE2F404.249
! SURFACE NEAR-IR ALBEDO FIELD ARE2F404.250
& , LAND_ICE_ALBEDO(NPD_FIELD) SWRAD3A.256
! SURFACE ALBEDO OF LAND OR SEA-ICE ADB1F401.1045
& , OPEN_SEA_ALBEDO(NPD_FIELD, 2) SWRAD3A.258
! SURFACE ALBEDO FIELD OF OPEN SEA ADB1F401.1046
! (DIRECT AND DIFFUSE COMPONENTS) ADB1F401.1047
& , LYING_SNOW(NPD_FIELD) ADB1F402.710
! MASS LOADING OF LYING SNOW ADB1F402.711
! SWRAD3A.260
! Level of tropopause ADB1F402.712
INTEGER ADB1F402.713
& TRINDX(NPD_FIELD) ADB1F402.714
! THE LAYER BOUNDARY OF THE TROPOPAUSE ADB1F402.715
! ADB1F402.716
! INCREMENT OF TIME: SWRAD3A.261
REAL !, INTENT(IN) SWRAD3A.262
& PTS SWRAD3A.263
! TIME INCREMENT SWRAD3A.264
! SWRAD3A.265
! SWRAD3A.270
! CALCULATED FLUXES: SWRAD3A.271
REAL !, INTENT(OUT) SWRAD3A.272
& SWOUT(NPD_FIELD, NLEVS+2) AJS1F401.1423
! NET DOWNWARD FLUXES SWRAD3A.274
& , SWSEA(NPD_FIELD) SWRAD3A.275
! SEA-SURFACE COMPONENTS OF FLUX SWRAD3A.276
& , NETSW(NPD_FIELD) SWRAD3A.277
! NET ABSORBED SHORTWAVE RADIATION SWRAD3A.278
! SWRAD3A.279
! SWRAD3A.280
! SWRAD3A.281
! DIAGNOSTICS: SWRAD3A.282
! SWRAD3A.283
! INPUT SWITCHES: SWRAD3A.284
LOGICAL !, INTENT(IN) SWRAD3A.285
& L_SOLAR_OUT_TOA SWRAD3A.286
! REFLECTED SOLAR TOA REQUIRED SWRAD3A.287
& , L_SOLAR_OUT_CLEAR SWRAD3A.288
! CLEAR REFLECTED SOLAR REQUIRED SWRAD3A.289
& , L_FLUX_BELOW_690NM_SURF SWRAD3A.290
! FLUX BELOW 690NM AT SURFACE TO BE DIAGNOSED ADB1F401.1048
& , L_SURFACE_DOWN_FLUX SWRAD3A.292
! DOWNWARD SURFACE FLUX REQUIRED SWRAD3A.293
& , L_SURF_DOWN_CLR SWRAD3A.294
! CALCULATE DOWNWARD CLEAR FLUX SWRAD3A.295
& , L_SURF_UP_CLR SWRAD3A.296
! CALCULATE UPWARD CLEAR FLUX SWRAD3A.297
& , L_TOTAL_CLOUD_COVER SWRAD3A.298
! CALCULATE CLOUD COVER SWRAD3A.299
& , L_CLEAR_HR SWRAD3A.300
! CALCULATE CLEAR-SKY HEATING RATES SWRAD3A.301
& , L_NET_FLUX_TROP ADB2F404.1530
! CALCULATE NET DOWNWARD FLUX AT THE TROPOPAUSE ADB2F404.1531
& , L_UP_FLUX_TROP ADB2F404.1532
! CALCULATE UPWARD FLUX AT THE TROPOPAUSE ADB2F404.1533
! SWRAD3A.302
! CALCULATED DIAGNOSTICS: SWRAD3A.303
REAL !, INTENT(OUT) SWRAD3A.304
& SOLAR_OUT_TOA(NPD_FIELD) SWRAD3A.305
! REFLECTED SOLAR TOA SWRAD3A.306
& , SOLAR_OUT_CLEAR(NPD_FIELD) SWRAD3A.307
! CLEAR REFLECTED SOLAR SWRAD3A.308
& , FLUX_BELOW_690NM_SURF(NPD_FIELD) SWRAD3A.309
! NET SURFACE FLUX BELOW 690NM (AT POINTS WHERE THERE ADB1F401.1049
! IS SEA-ICE THIS IS WEIGHTED BY THE FRACTION OF OPEN SEA.) ADB1F401.1050
& , SURFACE_DOWN_FLUX(NPD_FIELD) SWRAD3A.311
! DOWNWARD SURFACE FLUX SWRAD3A.312
& , SURF_DOWN_CLR(NPD_FIELD) SWRAD3A.313
! DOWNWARD CLEAR SURFACE FLUX SWRAD3A.314
& , SURF_UP_CLR(NPD_FIELD) SWRAD3A.315
! UPWARD CLEAR SURFACE FLUX SWRAD3A.316
& , TOTAL_CLOUD_COVER(NPD_FIELD) SWRAD3A.317
! TOTAL CLOUD AMOUNT SWRAD3A.318
& , CLEAR_HR(NPD_FIELD, NLEVS) SWRAD3A.319
! CLEAR-SKY HEATING RATES SWRAD3A.320
& , NET_FLUX_TROP(NPD_FIELD) ADB2F404.1534
! NET DOWNWARD FLUX AT THE TROPOPAUSE ADB2F404.1535
& , UP_FLUX_TROP(NPD_FIELD) ADB2F404.1536
! UPWARD FLUX AT THE TROPOPAUSE ADB2F404.1537
! SWRAD3A.321
LOGICAL !, INTENT(IN) SWRAD3A.322
& L_LAYER_CLOUD_LIT SWRAD3A.323
! LAYER CLOUD AT LIT POINTS WANTED SWRAD3A.324
& , L_CONV_CLOUD_LIT SWRAD3A.325
! CONVECTIVE CLOUD AT LIT POINTS WANTED SWRAD3A.326
REAL !, INTENT(IN) SWRAD3A.327
& LAYER_CLOUD_LIT(NPD_FIELD, NCLDS) SWRAD3A.328
! FRACTION OF LAYER CLOUD LIT SWRAD3A.329
& , CONV_CLOUD_LIT(NPD_FIELD) SWRAD3A.330
! FRACTION OF CONVECTIVE CLOUD LIT SWRAD3A.331
! SWRAD3A.332
! DIAGNOSTICS FOR THE MRF/UMIST PARAMETRIZATION SWRAD3A.333
! SWRAD3A.334
LOGICAL !, INTENT(IN) ADB2F404.1538
& RE_CONV_FLAG SWRAD3A.336
! DIAGNOSE EFFECTIVE RADIUS*WEIGHT FOR CONVECTIVE CLOUD SWRAD3A.337
& , RE_STRAT_FLAG SWRAD3A.338
! DIAGNOSE EFFECTIVE RADIUS*WEIGHT FOR STRATIFORM CLOUD SWRAD3A.339
& , WGT_CONV_FLAG SWRAD3A.340
! DIAGNOSE WEIGHT FOR CONVECTIVE CLOUD SWRAD3A.341
& , WGT_STRAT_FLAG SWRAD3A.342
! DIAGNOSE WEIGHT FOR STRATIFORM CLOUD SWRAD3A.343
& , LWP_STRAT_FLAG SWRAD3A.344
! DIAGNOSE LIQUID WATER PATH*WEIGHT FOR STRATIFORM CLOUD SWRAD3A.345
& , WEIGHTED_RE_FLAG AAJ3F404.16
! CALCULATE OBSERVED EFFECTIVE RADIUS AAJ3F404.17
& , SUM_WEIGHT_RE_FLAG AAJ3F404.18
! CALCULATE SUM OF WEIGHTS FOR EFFECTIVE RADIUS AAJ3F404.19
& , NTOT_DIAG_FLAG AAJ3F404.20
! DIAGNOSE DROPLET CONCENTRATION*WEIGHT AAJ3F404.21
& , STRAT_LWC_DIAG_FLAG AAJ3F404.22
! DIAGNOSE STRATIFORM LWC*WEIGHT AAJ3F404.23
& , SO4_CCN_DIAG_FLAG AAJ3F404.24
! DIAGNOSE SO4 CCN MASS CONC*COND. SAMP. WEIGHT AAJ3F404.25
& , COND_SAMP_WGT_FLAG AAJ3F404.26
! DIAGNOSE CONDITIONAL SAMPLING WEIGHT AAJ3F404.27
! SWRAD3A.346
REAL !, INTENT(OUT) ADB2F404.1539
& RE_CONV(NPD_FIELD, NCLDS) SWRAD3A.348
! EFFECTIVE RADIUS*WEIGHT FOR CONVECTIVE CLOUD SWRAD3A.349
& , RE_STRAT(NPD_FIELD, NCLDS) SWRAD3A.350
! EFFECTIVE RADIUS*WEIGHT FOR STRATIFORM CLOUD SWRAD3A.351
& , WGT_CONV(NPD_FIELD, NCLDS) SWRAD3A.352
! WEIGHT FOR CONVECTIVE CLOUD SWRAD3A.353
& , WGT_STRAT(NPD_FIELD, NCLDS) SWRAD3A.354
! WEIGHT FOR STRATIFORM CLOUD SWRAD3A.355
& , LWP_STRAT(NPD_FIELD, NCLDS) SWRAD3A.356
! LIQUID WATER PATH*WEIGHT FOR STRATIFORM CLOUD SWRAD3A.357
& , WEIGHTED_RE(NPD_FIELD) AAJ3F404.28
! WEIGHTED SUM OF EFFECTIVE RADII AAJ3F404.29
& , SUM_WEIGHT_RE(NPD_FIELD) AAJ3F404.30
! SUM OF WEIGHTS FOR EFFECTIVE RADIUS AAJ3F404.31
& , NTOT_DIAG(NPD_FIELD, NCLDS) AAJ3F404.32
! DROPLET CONCENTRATION*WEIGHT AAJ3F404.33
& , STRAT_LWC_DIAG(NPD_FIELD, NCLDS) AAJ3F404.34
! STRATIFORM LWC*WEIGHT AAJ3F404.35
& , SO4_CCN_DIAG(NPD_FIELD, NCLDS) AAJ3F404.36
! SO4 CCN MASS CONC*COND. SAMP. WEIGHT AAJ3F404.37
& , COND_SAMP_WGT(NPD_FIELD, NCLDS) AAJ3F404.38
! CONDITIONAL SAMPLING WEIGHT AAJ3F404.39
! AAJ3F404.40
! SWRAD3A.358
! SWRAD3A.359
! SWRAD3A.360
! SWRAD3A.361
! LOCAL VARIABLES. SWRAD3A.362
! SWRAD3A.363
INTEGER SWRAD3A.364
& I SWRAD3A.365
! LOOP VARIABLE SWRAD3A.366
& , L SWRAD3A.367
! LOOP VARIABLE SWRAD3A.368
LOGICAL SWRAD3A.369
& L_CLEAR SWRAD3A.370
! CALCULATE CLEAR-SKY FIELDS SWRAD3A.371
! FLAGS FOR PROCESSES ACTUALLY ENABLED. ADB1F401.1051
LOGICAL ADB1F401.1052
& L_RAYLEIGH ADB1F401.1053
! LOCAL FLAG FOR RAYLEIGH SCATTERING ADB1F401.1054
& , L_GAS ADB1F401.1055
! LOCAL FLAG FOR GASEOUS ABSORPTION ADB1F401.1056
& , L_CONTINUUM ADB1F401.1057
! LOCAL FLAG FOR CONTINUUM ABSORPTION ADB1F401.1058
& , L_DROP ADB1F401.1059
! LOCAL FLAG FOR SCATTERING BY DROPLETS ADB1F401.1060
& , L_AEROSOL ADB1F401.1061
! LOCAL FLAG FOR SCATTERING BY AEROSOLS ADB1F401.1062
& , L_AEROSOL_CCN ADB1F401.1063
! LOCAL FLAG TO USE AEROSOLS TO DETERMINE CCN ADB1F401.1064
& , L_ICE ADB1F401.1065
! LOCAL FLAG FOR SCATTERING BY ICE CRYSTALS ADB1F401.1066
INTEGER SWRAD3A.372
& I_SOLVER_CLEAR SWRAD3A.373
! SOLVER FOR CLEAR-SKY FLUXES SWRAD3A.374
& , I_GAS_OVERLAP(NPD_BAND_SW) ADB2F404.1540
! OVERLAPS IN EACH BAND SWRAD3A.376
! SWRAD3A.377
! GENERAL ATMOSPHERIC PROPERTIES: SWRAD3A.378
REAL SWRAD3A.379
& D_MASS(NPD_PROFILE, NPD_LAYER) SWRAD3A.380
! MASS THICKNESSES OF LAYERS SWRAD3A.381
& , P(NPD_PROFILE, 0: NPD_LAYER) SWRAD3A.382
! PRESSURE FIELD SWRAD3A.383
& , T(NPD_PROFILE, 0: NPD_LAYER) SWRAD3A.384
! TEMPERATURE FIELD SWRAD3A.385
& , GAS_MIX_RATIO(NPD_PROFILE, 0: NPD_LAYER, NPD_SPECIES_SW) ADB2F404.1541
! MASS FRACTIONS OF GASES SWRAD3A.387
& , NULLMMR SWRAD3A.388
! NULL MASS MIXING RATIO SWRAD3A.389
PARAMETER( SWRAD3A.390
& NULLMMR=0.0E+00 SWRAD3A.391
& ) SWRAD3A.392
! SWRAD3A.393
! CLOUDY PROPERTIES: SWRAD3A.394
INTEGER SWRAD3A.395
& N_CONDENSED SWRAD3A.396
! NUMBER OF CONDENSED PHASES SWRAD3A.397
& , TYPE_CONDENSED(NPD_CLOUD_COMPONENT) SWRAD3A.398
! TYPES OF CONDENSED COMPONENTS SWRAD3A.399
& , I_CONDENSED_PARAM(NPD_CLOUD_COMPONENT) SWRAD3A.400
! PARAMETRIZATION SCHEMES FOR COMPONENTS SWRAD3A.401
& , N_CLOUD_TOP_GLOBAL ADB1F402.895
! INVERTED GLOBAL TOPMOST CLOUDY LAYER ADB1F402.896
REAL SWRAD3A.402
& CONDENSED_PARAM_LIST(NPD_CLOUD_PARAMETER_SW ADB2F404.1542
& , NPD_CLOUD_COMPONENT, NPD_BAND_SW) ADB2F404.1543
! PARAMETERS FOR CONDENSED PHASES SWRAD3A.405
& , CONDENSED_DIM_CHAR(NPD_PROFILE, 0: NPD_LAYER ADB2F404.1544
& , NPD_CLOUD_COMPONENT) ADB2F404.1545
! CHARACTERISTIC DIMENSIONS OF CONDENSED SPECIES ADB2F404.1546
& , CONDENSED_MIX_RATIO(NPD_PROFILE, 0: NPD_LAYER SWRAD3A.408
& , NPD_CLOUD_COMPONENT) SWRAD3A.409
! MASS FRACTIONS OF CONDENSED SPECIES SWRAD3A.410
& , W_CLOUD(NPD_PROFILE, NPD_LAYER) SWRAD3A.411
! CLOUD AMOUNTS SWRAD3A.412
& , FRAC_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SWRAD3A.413
! FRACTIONS OF DIFFERENT TYPES OF CLOUD SWRAD3A.414
& , CONDENSED_MIN_DIM(NPD_CLOUD_COMPONENT) ADB2F404.1547
! MINIMUM DIMENSIONS OF CONDENSED COMPONENTS ADB2F404.1548
& , CONDENSED_MAX_DIM(NPD_CLOUD_COMPONENT) ADB2F404.1549
! MAXIMUM DIMENSIONS OF CONDENSED COMPONENTS ADB2F404.1550
! SWRAD3A.415
! PROPERTIES OF AEROSOLS: SWRAD3A.416
REAL SWRAD3A.417
& AEROSOL_MIX_RATIO(NPD_PROFILE, 0: NPD_LAYER SWRAD3A.418
& , NPD_AEROSOL_SPECIES_SW) ADB2F404.1551
! MIXING RATIOS OF AEROSOLS SWRAD3A.420
! SWRAD3A.421
! SOLAR FIELDS: SWRAD3A.422
REAL SWRAD3A.423
& SEC_0(NPD_PROFILE) SWRAD3A.424
! SECANTS OF ZENITH ANGLE SWRAD3A.425
& , SOLAR_INCIDENT_NORM(NPD_PROFILE) SWRAD3A.426
! NORMALLY INCIDENT SOLAR IRRADIANCE SWRAD3A.427
! SWRAD3A.428
! SURFACE PROPERTIES: SWRAD3A.429
LOGICAL SWRAD3A.430
& LAND_G(NPD_PROFILE) SWRAD3A.431
! GATHERED SURFACE MASK SWRAD3A.432
INTEGER SWRAD3A.433
& I_SURFACE(NPD_PROFILE) SWRAD3A.434
! TYPES OF SURFACE AT EACH POINT SWRAD3A.435
REAL SWRAD3A.436
& ALBEDO_FIELD_DIFF_GREY(NPD_PROFILE) SWRAD3A.437
! DIFFUSE ALBEDO FIELD SWRAD3A.438
& , ALBEDO_FIELD_DIR_GREY(NPD_PROFILE) SWRAD3A.439
! DIRECT ALBEDO FIELD SWRAD3A.440
& , ALBEDO_FIELD_DIFF(NPD_PROFILE, NPD_BAND_SW) ADB2F404.1552
! DIFFUSE ALBEDO FIELD SWRAD3A.442
& , ALBEDO_FIELD_DIR(NPD_PROFILE, NPD_BAND_SW) ADB2F404.1553
! DIRECT ALBEDO FIELD SWRAD3A.444
& , EMISSIVITY_FIELD(NPD_PROFILE, NPD_BAND_SW) ADB2F404.1554
! EMISSIVITY FIELD SWRAD3A.446
& , ALBEDO_SEA_DIFF_G(NPD_PROFILE, NPD_BAND_SW) ADB2F404.1555
! GATHERED DIFFUSE ALBEDO FOR OPEN SEA SWRAD3A.448
& , ALBEDO_SEA_DIR_G(NPD_PROFILE, NPD_BAND_SW) ADB2F404.1556
! GATHERED DIRECT ALBEDO FOR OPEN SEA SWRAD3A.450
! SWRAD3A.451
! FLUXES: SWRAD3A.452
REAL SWRAD3A.453
& FLUX_DIRECT(NPD_PROFILE, 0: NPD_LAYER) SWRAD3A.454
! DIRECT FLUX SWRAD3A.455
& , FLUX_DIRECT_CLEAR(NPD_PROFILE, 0: NPD_LAYER) SWRAD3A.456
! CLEAR-SKY DIRECT FLUX SWRAD3A.457
& , FLUX_NET(NPD_PROFILE, 0: NPD_LAYER) SWRAD3A.458
! NET/DOWNWARD FLUX SWRAD3A.459
& , FLUX_NET_CLEAR(NPD_PROFILE, 0: NPD_LAYER) SWRAD3A.460
! CLEAR-SKY NET/DOWNWARD TOTAL FLUX ADB1F401.1067
& , FLUX_UP(NPD_PROFILE, 0: NPD_LAYER) SWRAD3A.462
! UPWARD FLUX SWRAD3A.463
& , FLUX_UP_CLEAR(NPD_PROFILE, 0: NPD_LAYER) SWRAD3A.464
! CLEAR-SKY UPWARD FLUX SWRAD3A.465
! SWRAD3A.466
! ARRAYS FOR USE WITH DIAGNOSTICS: SWRAD3A.467
REAL SWRAD3A.468
& WEIGHT_690NM(NPD_BAND_SW) ADB2F404.1557
! WEIGHTS FOR EACH BAND FOR REGION BELOW 690 NM SWRAD3A.470
& , W_CLOUD_DIAG(NPDWD_CL_PROFILE, NPD_LAYER) ADB2F404.1558
! CLOUD AMOUNTS FOR DIAGNOSTIC USE SWRAD3A.472
! SWRAD3A.473
! SURFACE FLUXES FOR COUPLING OR DIAGNOSTIC USE SWRAD3A.474
REAL SWRAD3A.475
& SEA_FLUX_G(NPD_PROFILE) SWRAD3A.476
! NET DOWNWARD FLUX INTO SEA SWRAD3A.477
& , SURFACE_DOWN_FLUX_G(NPD_PROFILE) SWRAD3A.478
! DOWNWARD FLUX AT SURFACE SWRAD3A.479
& , SURF_DOWN_CLR_G(NPD_PROFILE) SWRAD3A.480
! CLEAR-SKY DOWNWARD FLUX AT SURFACE SWRAD3A.481
& , SURF_UP_CLR_G(NPD_PROFILE) SWRAD3A.482
! CLEAR-SKY UPWARD FLUX AT SURFACE SWRAD3A.483
& , FLUX_BELOW_690NM_SURF_G(NPD_PROFILE) SWRAD3A.484
! GATHERED SURFACE FLUX BELOW 690NM SWRAD3A.485
! SWRAD3A.486
! FIELDS REQUIRED FOR CALL TO RADIATION CODE BUT NOT USED SWRAD3A.487
INTEGER SWRAD3A.488
& N_ORDER_GAUSS SWRAD3A.489
& , I_GAS SWRAD3A.490
LOGICAL SWRAD3A.491
& L_SWITCH_SCATTER(NPD_BAND_SW) ADB2F404.1559
! SWRAD3A.493
! AUXILIARY VARIABLES: SWRAD3A.494
REAL SWRAD3A.495
& CPBYG SWRAD3A.496
! SPECIFIC HEAT BY GRAVITY SWRAD3A.497
& , DACON SWRAD3A.498
! DIFFERENCE IN A's SWRAD3A.499
& , DBCON SWRAD3A.500
! DIFFERENCE IN B's SWRAD3A.501
& , WEIGHT_BAND(NPD_BAND_SW) ADB2F404.1560
! WEIGHTING FACTORS FOR BANDS SWRAD3A.503
PARAMETER(CPBYG=CP/G) SWRAD3A.504
! SWRAD3A.505
! VARIABLES REQUIRED FOR COMPATIBILITY WITH SUBROUTINES: SWRAD3A.506
INTEGER ADB1F401.1068
& N_FRAC_ICE_POINT ADB1F401.1069
& , I_FRAC_ICE_POINT(NPD_PROFILE) ADB1F401.1070
REAL SWRAD3A.507
& DUMMY ADB2F404.1561
! SWRAD3A.511
! SWRAD3A.512
! SUBROUTINES CALLED: SWRAD3A.513
EXTERNAL SWRAD3A.514
& R2_SET_GAS_MIX_RATIO, R2_SET_THERMODYNAMIC SWRAD3A.515
& , R2_SET_AEROSOL_FIELD, R2_SET_CLOUD_FIELD SWRAD3A.516
& , R2_SET_CLOUD_PARAMETRIZATION SWRAD3A.517
& , R2_SET_SURFACE_FIELD_SW, R2_ZERO_1D SWRAD3A.518
& , R2_INIT_MRF_UMIST_DIAG SWRAD3A.519
& , R2_COMPARE_PROC ADB1F401.1072
! SWRAD3A.526
! SWRAD3A.527
! SWRAD3A.528
! SWRAD3A.529
! SWRAD3A.530
! SWRAD3A.531
! INITIALIZE THE ERROR FLAG FOR THE RADIATION CODE. SWRAD3A.532
IERR=I_NORMAL SWRAD3A.533
! SWRAD3A.534
! INITIALIZATIONS FOR DIAGNOSTICS DEPENDING ON BANDS ARE2F404.251
! SWRAD3A.535
IF ( L_FLUX_BELOW_690NM_SURF .OR. L_SNOW_ALBEDO ) THEN ARE2F404.252
CALL R2_SET_690NM_WEIGHT(N_BAND_SW ARE2F404.253
& , L_PRESENT_SW ARE2F404.254
& , N_BAND_EXCLUDE_SW ARE2F404.255
& , INDEX_EXCLUDE_SW ARE2F404.256
& , WAVE_LENGTH_SHORT_SW ARE2F404.257
& , WAVE_LENGTH_LONG_SW ARE2F404.258
& , WEIGHT_690NM ARE2F404.259
& , NPD_BAND_SW, NPD_EXCLUDE_SW, NPD_TYPE_SW ARE2F404.260
& ) ARE2F404.261
ENDIF ARE2F404.262
! ARE2F404.263
! COMPARE PROCESSES IN THE SPECTRAL FILE WITH THOSE ENABLED IN ADB1F401.1073
! THE CODE. ADB1F401.1074
CALL R2_COMPARE_PROC(IERR, L_PRESENT_SW ADB2F404.1562
& , L_RAYLEIGH_SW, L_GAS_SW, L_CONTINUUM_SW ADB1F401.1076
& , L_DROP_SW, L_AEROSOL_SW, L_AEROSOL_CCN_SW, L_ICE_SW ADB1F401.1077
& , L_USE_SULPC_DIRECT, L_USE_SULPC_INDIRECT ADB1F401.1078
& , L_USE_SOOT_DIRECT ALR3F405.118
& , L_CLIMAT_AEROSOL ADB1F402.717
& , L_RAYLEIGH, L_GAS, L_CONTINUUM ADB1F401.1079
& , L_DROP, L_AEROSOL, L_AEROSOL_CCN, L_ICE ADB1F401.1080
& , NPD_TYPE_SW ADB2F404.1563
& ) ADB1F401.1082
IF (IERR.NE.I_NORMAL) RETURN ADB1F401.1083
! ADB1F401.1084
! ADB1F401.1085
! ADB1F402.718
! SET THE PROPERTIES OF THE SURFACE SWRAD3A.536
CALL R2_SET_SURFACE_FIELD_SW( SWRAD3A.537
& N_BAND_SW ADB2F404.1564
& , NLIT, LIST SWRAD3A.539
& , I_SURFACE, I_SPEC_SURFACE_SW ADB2F404.1565
& , L_SURFACE_SW ADB2F404.1566
& , L_MICROPHYSICS, L_SNOW_ALBEDO, SAL_DIM ARE2F404.264
& , LAND, OPEN_SEA_ALBEDO, LAND_ICE_ALBEDO, ICE_FRACTION SWRAD3A.543
& , SAL_VIS, SAL_NIR, WEIGHT_690NM ARE2F404.265
& , EMISSIVITY_FIELD, ALBEDO_FIELD_DIR, ALBEDO_FIELD_DIFF SWRAD3A.544
& , LAND_G, ALBEDO_SEA_DIFF_G, ALBEDO_SEA_DIR_G SWRAD3A.545
& , NPD_FIELD, NPD_PROFILE, NPD_BAND_SW, NPD_SURFACE_SW ADB2F404.1567
& ) SWRAD3A.547
! SWRAD3A.548
! SET THE MIXING RATIOS OF GASES. SWRAD3A.549
CALL R2_SET_GAS_MIX_RATIO(IERR SWRAD3A.550
& , NLIT, NLEVS, NWET, NOZONE SWRAD3A.551
& , LIST SWRAD3A.552
& , N_ABSORB_SW, TYPE_ABSORB_SW ADB2F404.1568
& , .FALSE., .FALSE., .FALSE., .FALSE., L_O2_SW ADB2F404.1569
& , .FALSE., .FALSE., .FALSE., .FALSE. ADB1F405.952
& , H2O, CO2, O3, NULLMMR, NULLMMR, NULLMMR, NULLMMR SWRAD3A.555
& , O2_MIX_RATIO SWRAD3A.556
& , NULLMMR, NULLMMR, NULLMMR, NULLMMR ADB1F405.953
& , GAS_MIX_RATIO SWRAD3A.557
& , CO2_DIM1, CO2_DIM2, CO2_3D, L_CO2_3D ACN2F405.99
& , NPD_FIELD, NPD_PROFILE, NPD_LAYER, NPD_SPECIES_SW ADB2F404.1570
& ) SWRAD3A.559
IF (IERR.NE.I_NORMAL) RETURN SWRAD3A.560
! SWRAD3A.561
! SET THE THERMODYNAMIC PROPERTIES OF THE ATMOSPHERE. SWRAD3A.562
CALL R2_SET_THERMODYNAMIC(NLIT, NLEVS, LIST, .FALSE. SWRAD3A.563
& , PSTAR, DUMMY, AB, BB, AC, BC ADB2F404.1571
& , DUMMY, TAC ADB2F404.1572
& , P, T, DUMMY, DUMMY, D_MASS ADB2F404.1573
& , NPD_FIELD, NPD_PROFILE, NPD_LAYER SWRAD3A.567
& ) SWRAD3A.568
! SWRAD3A.569
! SWRAD3A.570
! SET THE MIXING RATIOS OF AEROSOLS. SWRAD3A.571
IF (L_AEROSOL.OR.L_AEROSOL_CCN) THEN ADB1F401.1088
CALL R2_SET_AEROSOL_FIELD(IERR ADB1F402.719
& , NLIT, NLEVS, N_AEROSOL_SW, TYPE_AEROSOL_SW ADB2F404.1574
& , LIST SWRAD3A.574
& , L_CLIMAT_AEROSOL, N_LEVELS_BL ADB1F402.721
& , L_USE_SULPC_DIRECT ADB2F404.1575
& , SULP_DIM1, SULP_DIM2 ADB1F402.723
& , ACCUM_SULPHATE, AITKEN_SULPHATE ADB1F402.724
&,L_USE_SOOT_DIRECT, SOOT_DIM1, SOOT_DIM2, FRESH_SOOT, AGED_SOOT ALR3F405.119
& , LAND, LYING_SNOW, PSTAR, AB, BB, TRINDX ADB1F402.725
& , AEROSOL_MIX_RATIO ADB1F402.726
& , NPD_FIELD, NPD_PROFILE, NPD_LAYER, NPD_AEROSOL_SPECIES_SW ADB2F404.1576
& ) SWRAD3A.577
ENDIF SWRAD3A.578
! SWRAD3A.579
! SWRAD3A.580
! ASSIGN THE PROPERTIES OF CLOUDS. SWRAD3A.581
! ADB2F404.1577
CALL R2_SET_CLOUD_PARAMETRIZATION(IERR, N_BAND_SW ADB2F404.1578
& , I_ST_WATER_SW, I_CNV_WATER_SW, I_ST_ICE_SW, I_CNV_ICE_SW ADB2F404.1579
& , L_DROP_TYPE_SW ADB2F404.1580
& , I_DROP_PARAMETRIZATION_SW ADB2F404.1581
& , DROP_PARAMETER_LIST_SW ADB2F404.1582
& , DROP_PARM_MIN_DIM_SW, DROP_PARM_MAX_DIM_SW ADB2F404.1583
& , L_ICE_TYPE_SW ADB2F404.1584
& , I_ICE_PARAMETRIZATION_SW ADB2F404.1585
& , ICE_PARAMETER_LIST_SW ADB2F404.1586
& , ICE_PARM_MIN_DIM_SW, ICE_PARM_MAX_DIM_SW ADB2F404.1587
& , I_CONDENSED_PARAM, CONDENSED_PARAM_LIST ADB2F404.1588
& , CONDENSED_MIN_DIM, CONDENSED_MAX_DIM ADB2F404.1589
& , NPD_BAND_SW ADB2F404.1590
& , NPD_DROP_TYPE_SW, NPD_ICE_TYPE_SW, NPD_CLOUD_PARAMETER_SW ADB2F404.1591
& ) ADB2F404.1592
IF (IERR.NE.I_NORMAL) RETURN ADB2F404.1593
! ADB2F404.1594
CALL R2_INIT_MRF_UMIST_DIAG(IERR SWRAD3A.582
& , RE_CONV, RE_CONV_FLAG, RE_STRAT, RE_STRAT_FLAG SWRAD3A.583
& , WGT_CONV, WGT_CONV_FLAG, WGT_STRAT, WGT_STRAT_FLAG SWRAD3A.584
& , LWP_STRAT, LWP_STRAT_FLAG SWRAD3A.585
& , NTOT_DIAG, NTOT_DIAG_FLAG AAJ3F404.41
& , STRAT_LWC_DIAG, STRAT_LWC_DIAG_FLAG AAJ3F404.42
& , SO4_CCN_DIAG, SO4_CCN_DIAG_FLAG AAJ3F404.43
& , COND_SAMP_WGT, COND_SAMP_WGT_FLAG AAJ3F404.44
& , NPD_FIELD, NPD_PROFILE, NCLDS SWRAD3A.586
& ) SWRAD3A.587
IF (IERR.NE.I_NORMAL) RETURN SWRAD3A.588
! ADB2F404.1595
CALL R2_SET_CLOUD_FIELD(NLIT, NLEVS, NCLDS SWRAD3A.589
& , LIST SWRAD3A.590
& , P, T, D_MASS SWRAD3A.591
& , CCB, CCT, CCA, CCCWP SWRAD3A.592
& , LCCWC1, LCCWC2, LCA_AREA, LCA_BULK ASK1F405.282
& , L_MICROPHYSICS, L_AEROSOL_CCN AYY1F404.370
& , SULP_DIM1, SULP_DIM2, ACCUM_SULPHATE, DISS_SULPHATE AYY1F404.371
& , L_CLOUD_WATER_PARTITION, LAND_G AYY1F404.372
& , I_CLOUD_REPRESENTATION_SW, I_CONDENSED_PARAM ADB2F404.1596
& , CONDENSED_MIN_DIM, CONDENSED_MAX_DIM ADB2F404.1597
& , N_CONDENSED, TYPE_CONDENSED SWRAD3A.596
& , W_CLOUD, FRAC_CLOUD, L_LOCAL_CNV_PARTITION_SW ADB1F405.954
& , CONDENSED_MIX_RATIO, CONDENSED_DIM_CHAR ADB2F404.1598
& , RE_CONV, RE_CONV_FLAG, RE_STRAT, RE_STRAT_FLAG SWRAD3A.599
& , WGT_CONV, WGT_CONV_FLAG, WGT_STRAT, WGT_STRAT_FLAG SWRAD3A.600
& , LWP_STRAT, LWP_STRAT_FLAG SWRAD3A.601
& , NTOT_DIAG, NTOT_DIAG_FLAG AAJ3F404.85
& , STRAT_LWC_DIAG, STRAT_LWC_DIAG_FLAG AAJ3F404.86
& , SO4_CCN_DIAG, SO4_CCN_DIAG_FLAG AAJ3F404.87
& , COND_SAMP_WGT, COND_SAMP_WGT_FLAG AAJ3F404.88
& , NPD_FIELD, NPD_PROFILE, NPD_LAYER, NPD_AEROSOL_SPECIES_SW ADB2F404.1599
& , N_CCA_LEV, L_3D_CCA AJX0F404.39
& ) SWRAD3A.603
! AAJ3F404.45
IF (WEIGHTED_RE_FLAG.AND.SUM_WEIGHT_RE_FLAG) THEN AAJ3F404.46
CALL R2_CLOUD_LEVEL_DIAG(IERR, NLIT, NLEVS, NCLDS AAJ3F404.47
& , LIST AAJ3F404.48
& , I_CLOUD_SW, I_CLOUD_REPRESENTATION_SW AAJ3F404.49
& , W_CLOUD, FRAC_CLOUD AAJ3F404.50
& , CONDENSED_MIX_RATIO, CONDENSED_DIM_CHAR AAJ3F404.51
& , WEIGHTED_RE_FLAG, WEIGHTED_RE, SUM_WEIGHT_RE AAJ3F404.52
& , NPD_FIELD, NPD_PROFILE, NPD_LAYER AAJ3F404.53
& ) AAJ3F404.54
IF (IERR.NE.I_NORMAL) RETURN AAJ3F404.55
ENDIF AAJ3F404.56
! SWRAD3A.617
! SWRAD3A.618
! SWRAD3A.619
! SET THE INCIDENT SOLAR FLUX. SWRAD3A.620
DO L=1, NLIT SWRAD3A.621
SOLAR_INCIDENT_NORM(L)=SCS*SC*LIT(LIST(L)) SWRAD3A.622
SEC_0(L)=1.0E+00/COSZIN(LIST(L)) SWRAD3A.623
ENDDO SWRAD3A.624
! SWRAD3A.625
! SWRAD3A.626
! CHECK THAT A VALID NUMBER HAS BEEN SUPPLIED FOR THE SOLVER. ADB1F405.955
IF ( (I_SOLVER_SW.NE.IP_SOLVER_PENTADIAGONAL).AND. ADB1F405.956
& (I_SOLVER_SW.NE.IP_SOLVER_MIX_11).AND. ADB1F405.957
& (I_SOLVER_SW.NE.IP_SOLVER_MIX_DIRECT).AND. ADB1F405.958
& (I_SOLVER_SW.NE.IP_SOLVER_HOMOGEN_DIRECT).AND. ADB1F405.959
& (I_SOLVER_SW.NE.IP_SOLVER_TRIPLE) ADB1F405.960
& ) THEN ADB1F405.961
WRITE(IU_ERR, '(/A, /A)') ADB1F405.962
& '*** ERROR: AN INVALID SOLVER HAS BEEN SELECTED ' ADB1F405.963
& , 'IN THE SHORTWAVE REGION.' ADB1F405.964
IERR=I_ERR_FATAL ADB1F405.965
RETURN ADB1F405.966
ENDIF ADB1F405.967
! ADB1F405.968
! ADB1F405.969
! ADB1F405.970
! SET CLEAR-SKY CALCULATIONS. SWRAD3A.627
L_CLEAR=L_SOLAR_OUT_CLEAR.OR. SWRAD3A.628
& L_SURF_DOWN_CLR.OR. SWRAD3A.629
& L_CLEAR_HR SWRAD3A.630
! SWRAD3A.631
IF (L_CLEAR) THEN SWRAD3A.632
! SWRAD3A.633
! SELECT A CLEAR-SKY SOLVER TO MATCH THE MAIN SOLVER. SWRAD3A.634
IF (I_SOLVER_SW.EQ.IP_SOLVER_PENTADIAGONAL) THEN SWRAD3A.635
I_SOLVER_CLEAR=IP_SOLVER_PENTADIAGONAL SWRAD3A.636
ELSE IF (I_SOLVER_SW.EQ.IP_SOLVER_MIX_11) THEN SWRAD3A.645
I_SOLVER_CLEAR=IP_SOLVER_PENTADIAGONAL SWRAD3A.646
ELSE IF (I_SOLVER_SW.EQ.IP_SOLVER_MIX_DIRECT) THEN ADB1F401.1099
I_SOLVER_CLEAR=IP_SOLVER_HOMOGEN_DIRECT ADB1F401.1100
ELSE IF (I_SOLVER_SW.EQ.IP_SOLVER_HOMOGEN_DIRECT) THEN ADB2F404.1600
I_SOLVER_CLEAR=IP_SOLVER_HOMOGEN_DIRECT ADB2F404.1601
ELSE IF (I_SOLVER_SW.EQ.IP_SOLVER_TRIPLE) THEN ADB1F402.727
I_SOLVER_CLEAR=IP_SOLVER_HOMOGEN_DIRECT ADB1F402.730
ENDIF SWRAD3A.655
! SWRAD3A.656
ENDIF SWRAD3A.657
! SWRAD3A.658
! SWRAD3A.659
! SET PROPERTIES FOR INDIVIDUAL BANDS. SWRAD3A.660
DO I=1, N_BAND_SW ADB2F404.1602
WEIGHT_BAND(I)=1.0E+00 SWRAD3A.662
I_GAS_OVERLAP(I)=I_GAS_OVERLAP_SW SWRAD3A.663
ENDDO SWRAD3A.664
! SWRAD3A.665
! SWRAD3A.666
! INVERT THE TOPMOST CLOUDY LAYER IF USING A GLOBAL VALUE. ADB1F402.898
IF (L_GLOBAL_CLOUD_TOP) THEN ADB1F402.899
N_CLOUD_TOP_GLOBAL=NLEVS+1-GLOBAL_CLOUD_TOP ADB1F402.900
ENDIF ADB1F402.901
! SWRAD3A.679
! SWRAD3A.680
! SWRAD3A.681
! SWRAD3A.682
CALL FLUX_CALC(IERR SWRAD3A.683
! Logical Flags for Processes SWRAD3A.684
& , L_RAYLEIGH, L_AEROSOL, L_GAS, L_CONTINUUM ADB1F401.1103
& , L_CLOUD_SW, L_DROP, L_ICE ADB1F401.1104
! Angular Integration SWRAD3A.687
& , I_ANGULAR_INTEGRATION_SW, I_2STREAM_SW, L_2_STREAM_CORRECT_SW SWRAD3A.688
& , L_RESCALE_SW, N_ORDER_GAUSS SWRAD3A.689
! Treatment of Scattering SWRAD3A.690
& , I_SCATTER_METHOD_SW, L_SWITCH_SCATTER SWRAD3A.691
! Options for treating clouds ADB1F402.902
& , L_GLOBAL_CLOUD_TOP, N_CLOUD_TOP_GLOBAL ADB1F402.903
! Options for Solver SWRAD3A.692
& , I_SOLVER_SW ADB1F405.971
! General Spectral Properties SWRAD3A.694
& , N_BAND_SW, 1, N_BAND_SW ADB2F404.1603
& , WEIGHT_BAND SWRAD3A.696
! General Atmospheric Properties SWRAD3A.697
& , NLIT, NLEVS SWRAD3A.698
& , L_LAYER_SW, L_CLOUD_LAYER_SW SWRAD3A.699
& , P, T, DUMMY, DUMMY, D_MASS ADB2F404.1604
! Spectral Region SWRAD3A.701
& , ISOLIR_SW SWRAD3A.702
! Solar Fields SWRAD3A.703
& , SEC_0, SOLAR_INCIDENT_NORM, SOLAR_FLUX_BAND_SW ADB2F404.1605
& , RAYLEIGH_COEFFICIENT_SW ADB2F404.1606
! Infra-red Fields SWRAD3A.706
& , N_DEG_FIT_SW ADB2F404.1607
& , THERMAL_COEFFICIENT_SW ADB2F404.1608
& , T_REF_PLANCK_SW, .FALSE. ADB2F404.1609
! Gaseous Absorption SWRAD3A.710
& , N_ABSORB_SW, I_GAS_OVERLAP, I_GAS ADB2F404.1610
& , GAS_MIX_RATIO SWRAD3A.712
& , N_BAND_ABSORB_SW, INDEX_ABSORB_SW ADB2F404.1611
& , I_BAND_ESFT_SW ADB2F404.1612
& , W_ESFT_SW, K_ESFT_SW ADB2F404.1613
& , I_SCALE_ESFT_SW, I_SCALE_FNC_SW ADB2F404.1614
& , SCALE_VECTOR_SW ADB2F404.1615
& , P_REFERENCE_SW, T_REFERENCE_SW ADB2F404.1616
! Doppler Broadening SWRAD3A.719
& , L_DOPPLER_PRESENT_SW ADB2F404.1617
& , DOPPLER_CORRECTION_SW ADB2F404.1618
! Surface Fields SWRAD3A.722
& , L_SURFACE_SW, I_SURFACE ADB2F404.1619
& , I_SPEC_SURFACE_SW ADB2F404.1620
& , SURFACE_ALBEDO_SW ADB2F404.1621
& , ALBEDO_FIELD_DIFF, ALBEDO_FIELD_DIR SWRAD3A.726
& , N_DIR_ALBEDO_FIT_SW ADB2F404.1622
& , DIRECT_ALBEDO_PARM_SW ADB2F404.1623
& , EMISSIVITY_GROUND_SW ADB2F404.1624
& , EMISSIVITY_FIELD SWRAD3A.730
! Continuum Absorption SWRAD3A.731
& , N_BAND_CONTINUUM_SW ADB2F404.1625
& , INDEX_CONTINUUM_SW, INDEX_WATER_SW ADB2F404.1626
& , K_CONTINUUM_SW, I_SCALE_FNC_CONT_SW ADB2F404.1627
& , SCALE_CONTINUUM_SW ADB2F404.1628
& , P_REF_CONTINUUM_SW ADB2F404.1629
& , T_REF_CONTINUUM_SW ADB2F404.1630
! Properties of Aerosols SWRAD3A.738
& , N_AEROSOL_SW ADB2F404.1631
& , AEROSOL_MIX_RATIO SWRAD3A.740
& , AEROSOL_ABSORPTION_SW ADB2F404.1632
& , AEROSOL_SCATTERING_SW ADB2F404.1633
& , AEROSOL_ASYMMETRY_SW ADB2F404.1634
& , I_AEROSOL_PARAMETRIZATION_SW ADB2F404.1635
& , NHUMIDITY_SW ADB2F404.1636
& , HUMIDITIES_SW ADB2F404.1637
! Properties of Clouds SWRAD3A.747
& , N_CONDENSED, TYPE_CONDENSED SWRAD3A.748
& , I_CLOUD_SW, I_CLOUD_REPRESENTATION_SW, W_CLOUD, FRAC_CLOUD SWRAD3A.749
& , CONDENSED_MIX_RATIO, CONDENSED_DIM_CHAR ADB2F404.1638
& , I_CONDENSED_PARAM, CONDENSED_PARAM_LIST SWRAD3A.751
! Fluxes Calculated SWRAD3A.752
& , FLUX_DIRECT, FLUX_NET, FLUX_UP SWRAD3A.753
! Options for Clear-sky Fluxes SWRAD3A.754
& , L_CLEAR, I_SOLVER_CLEAR SWRAD3A.755
! Clear-sky Fluxes Calculated SWRAD3A.756
& , FLUX_DIRECT_CLEAR, FLUX_NET_CLEAR, FLUX_UP_CLEAR SWRAD3A.757
! Arrays specific to the UM SWRAD3A.758
! Arrays for Coupling SWRAD3A.759
& , N_FRAC_ICE_POINT, I_FRAC_ICE_POINT, ICE_FRACTION ADB1F401.1105
& , ALBEDO_SEA_DIFF_G, ALBEDO_SEA_DIR_G SWRAD3A.760
& , SEA_FLUX_G SWRAD3A.761
! Arrays for diagnostics specific to the UM SWRAD3A.762
& , L_FLUX_BELOW_690NM_SURF, WEIGHT_690NM SWRAD3A.763
& , FLUX_BELOW_690NM_SURF_G SWRAD3A.764
& , L_SURFACE_DOWN_FLUX, SURFACE_DOWN_FLUX_G SWRAD3A.765
& , L_SURF_DOWN_CLR, SURF_DOWN_CLR_G SWRAD3A.766
& , L_SURF_UP_CLR, SURF_UP_CLR_G SWRAD3A.767
! Dimensions of Arrays SWRAD3A.768
& , NPD_PROFILE, NPD_LAYER, NPD_COLUMN SWRAD3A.769
& , NPD_BAND_SW ADB2F404.1639
& , NPD_SPECIES_SW ADB2F404.1640
& , NPD_ESFT_TERM_SW, NPD_SCALE_FNC_SW ADB2F404.1641
& , NPD_SCALE_VARIABLE_SW ADB2F404.1642
& , NPD_CONTINUUM_SW ADB2F404.1643
& , NPD_AEROSOL_SPECIES_SW ADB2F404.1644
& , NPD_HUMIDITIES_SW ADB2F404.1645
& , NPD_CLOUD_PARAMETER_SW ADB2F404.1646
& , NPD_THERMAL_COEFF_SW ADB2F404.1647
& , NPD_SURFACE_SW, NPD_ALBEDO_PARM_SW ADB2F404.1648
& ) SWRAD3A.780
IF (IERR.NE.I_NORMAL) RETURN SWRAD3A.781
! SWRAD3A.782
! SWRAD3A.783
! PREPARE THE OUTPUT ARRAYS: SWRAD3A.784
! SWRAD3A.785
! ZERO SWOUT SO THAT POINTS LYING IN THE NIGHT WILL CONTAIN VALID SWRAD3A.786
! FLUXES AFTER SCATTERING. SWRAD3A.787
DO I=1, NLEVS+1 SWRAD3A.788
CALL R2_ZERO_1D(N_PROFILE, SWOUT(1, I)) SWRAD3A.789
ENDDO SWRAD3A.790
IF (L_CLEAR_HR) THEN SWRAD3A.791
DO I=1, NLEVS SWRAD3A.792
CALL R2_ZERO_1D(N_PROFILE, CLEAR_HR(1, I)) SWRAD3A.793
ENDDO SWRAD3A.794
ENDIF SWRAD3A.795
! SWRAD3A.796
! SCATTER THE NET DOWNWARD FLUX AT EACH LEVEL INTO SWOUT. SWRAD3A.797
DO I=1, NLEVS+1 SWRAD3A.798
DO L=1, NLIT SWRAD3A.799
SWOUT(LIST(L), I)=FLUX_NET(L, NLEVS+1-I) SWRAD3A.800
ENDDO SWRAD3A.801
ENDDO SWRAD3A.802
! SWRAD3A.803
! SWRAD3A.804
! NET SHORTWAVE RADIATION ABSORBED BY THE PLANET SWRAD3A.805
! (I. E. EARTH AND ATMOSPHERE TOGETHER): SWRAD3A.806
! SWRAD3A.807
CALL R2_ZERO_1D(N_PROFILE, NETSW) SWRAD3A.808
DO L=1, NLIT SWRAD3A.809
NETSW(LIST(L))=SWOUT(LIST(L), NLEVS+1) SWRAD3A.810
ENDDO SWRAD3A.811
! SWRAD3A.812
! SWRAD3A.813
! SWRAD3A.814
! SWRAD3A.815
! ASSIGNMENT OF DIAGNOSTICS: SWRAD3A.816
! SWRAD3A.817
! TOTAL CLOUD COVER: SWRAD3A.818
! SWRAD3A.819
IF (L_TOTAL_CLOUD_COVER) THEN SWRAD3A.820
! SWRAD3A.821
! THE CLOUD AMOUNTS MUST BE RECALCULATED SINCE W_CLOUD SWRAD3A.822
! AS DEFINED ABOVE HOLDS VALUES ONLY AT LIT POINTS. SWRAD3A.823
! A DIFFERENTLY DEFINED DIAGNOSTIC ARRAY IS USED TO PREVENT SWRAD3A.824
! OUR HAVING TO DECLARE A LOT OF SPACE FOR W_CLOUD. SWRAD3A.825
IF (L_3D_CCA) THEN AJX0F404.40
DO I=NLEVS+1-NCLDS, NLEVS SWRAD3A.826
DO L=1, N_PROFILE SWRAD3A.827
W_CLOUD_DIAG(L,I) = CCA(L,NLEVS+1-I) AJX0F404.41
& +(1.0E+00-CCA(L,NLEVS+1-I))*LCA_AREA(L,NLEVS+1-I) ASK1F405.283
ENDDO AJX0F404.43
ENDDO AJX0F404.44
ELSE AJX0F404.45
DO I=NLEVS+1-NCLDS, NLEVS AJX0F404.46
DO L=1, N_PROFILE AJX0F404.47
IF ( (CCT(L).GE.NLEVS+2-I).AND.(CCB(L).LE.NLEVS+1-I) ) SWRAD3A.828
& THEN SWRAD3A.829
W_CLOUD_DIAG(L, I) SWRAD3A.830
& =CCA(L,1)+(1.0E+00-CCA(L,1))*LCA_AREA(L, NLEVS+1-I) ASK1F405.284
ELSE SWRAD3A.832
W_CLOUD_DIAG(L, I)=LCA_AREA(L, NLEVS+1-I) ASK1F405.285
ENDIF SWRAD3A.834
ENDDO SWRAD3A.835
ENDDO SWRAD3A.836
ENDIF AJX0F404.49
! SWRAD3A.837
CALL R2_CALC_TOTAL_CLOUD_COVER(N_PROFILE, NLEVS, NCLDS SWRAD3A.838
& , I_CLOUD_SW, W_CLOUD_DIAG, TOTAL_CLOUD_COVER SWRAD3A.839
& , NPDWD_CL_PROFILE, NPD_LAYER ADB1F405.972
& ) SWRAD3A.841
! SWRAD3A.842
ENDIF SWRAD3A.843
! SWRAD3A.844
! SWRAD3A.845
! AMOUNT OF CONVECTIVE CLOUD AT DAYLIT POINTS. SWRAD3A.846
IF (L_CONV_CLOUD_LIT) THEN SWRAD3A.847
! ZERO THE ARRAY EVERYWHERE AND FILL ONLY AT LIT POINTS. SWRAD3A.848
CALL R2_ZERO_1D(N_PROFILE, CONV_CLOUD_LIT) SWRAD3A.849
IF (L_3D_CCA) THEN AJX0F404.50
DO L=1, NLIT SWRAD3A.850
CONV_CLOUD_LIT(LIST(L))=CCA( LIST(L),CCT(LIST(L)) ) AJX0F404.51
ENDDO SWRAD3A.852
ELSE AJX0F404.52
DO L=1, NLIT AJX0F404.53
CONV_CLOUD_LIT(LIST(L))=CCA(LIST(L),1) AJX0F404.54
ENDDO AJX0F404.55
ENDIF AJX0F404.56
ENDIF SWRAD3A.853
! SWRAD3A.854
! SWRAD3A.855
! AMOUNT OF STRATIFORM CLOUD AT DAYLIT POINTS. SWRAD3A.856
IF (L_LAYER_CLOUD_LIT) THEN SWRAD3A.857
DO I=1, NCLDS SWRAD3A.858
CALL R2_ZERO_1D(N_PROFILE, LAYER_CLOUD_LIT(1, I)) SWRAD3A.859
DO L=1, NLIT SWRAD3A.860
LAYER_CLOUD_LIT(LIST(L), I)=LCA_AREA(LIST(L), I) ASK1F405.286
ENDDO SWRAD3A.862
ENDDO SWRAD3A.863
ENDIF SWRAD3A.864
! SWRAD3A.865
! SWRAD3A.866
! OUTGOING SOLAR RADIATION AT TOA: SWRAD3A.867
! SWRAD3A.868
IF (L_SOLAR_OUT_TOA) THEN SWRAD3A.869
CALL R2_ZERO_1D(N_PROFILE, SOLAR_OUT_TOA) SWRAD3A.870
DO L=1, NLIT SWRAD3A.871
SOLAR_OUT_TOA(LIST(L))=SOLAR_INCIDENT_NORM(L)/SEC_0(L) SWRAD3A.872
& -FLUX_NET(L, 0) SWRAD3A.873
ENDDO SWRAD3A.874
ENDIF SWRAD3A.875
! SWRAD3A.876
! SWRAD3A.877
! CLEAR-SKY OUTGOING SOLAR RADIATION AT TOA: SWRAD3A.878
! SWRAD3A.879
IF (L_SOLAR_OUT_CLEAR) THEN SWRAD3A.880
CALL R2_ZERO_1D(N_PROFILE, SOLAR_OUT_CLEAR) SWRAD3A.881
DO L=1, NLIT SWRAD3A.882
SOLAR_OUT_CLEAR(LIST(L))=SOLAR_INCIDENT_NORM(L)/SEC_0(L) SWRAD3A.883
& -FLUX_NET_CLEAR(L, 0) SWRAD3A.884
ENDDO SWRAD3A.885
ENDIF SWRAD3A.886
! SWRAD3A.887
! SWRAD3A.888
! SURFACE FLUX BELOW 690NM. SWRAD3A.889
! SWRAD3A.890
IF (L_FLUX_BELOW_690NM_SURF) THEN SWRAD3A.891
CALL R2_ZERO_1D(N_PROFILE, FLUX_BELOW_690NM_SURF) SWRAD3A.892
DO L=1, NLIT SWRAD3A.893
IF (LAND(LIST(L))) THEN ADB1F401.1106
FLUX_BELOW_690NM_SURF(LIST(L)) ADB1F401.1107
& =FLUX_BELOW_690NM_SURF_G(L) ADB1F401.1108
ELSE ADB1F401.1109
FLUX_BELOW_690NM_SURF(LIST(L)) ADB1F401.1110
& =FLUX_BELOW_690NM_SURF_G(L) ADB1F401.1111
& *(1.0E+00-ICE_FRACTION(LIST(L))) ADB1F401.1112
ENDIF ADB1F401.1113
ENDDO SWRAD3A.895
ENDIF SWRAD3A.896
! SWRAD3A.897
! SWRAD3A.898
! DOWNWARD FLUX AT THE SURFACE: SWRAD3A.899
! SWRAD3A.900
IF (L_SURFACE_DOWN_FLUX) THEN SWRAD3A.901
CALL R2_ZERO_1D(N_PROFILE, SURFACE_DOWN_FLUX) SWRAD3A.902
DO L=1, NLIT SWRAD3A.903
SURFACE_DOWN_FLUX(LIST(L))=SURFACE_DOWN_FLUX_G(L) SWRAD3A.904
ENDDO SWRAD3A.905
ENDIF SWRAD3A.906
! SWRAD3A.907
! SWRAD3A.908
! CLEAR-SKY DOWNWARD FLUX AT THE SURFACE: SWRAD3A.909
! SWRAD3A.910
IF (L_SURF_DOWN_CLR) THEN SWRAD3A.911
CALL R2_ZERO_1D(N_PROFILE, SURF_DOWN_CLR) SWRAD3A.912
DO L=1, NLIT SWRAD3A.913
SURF_DOWN_CLR(LIST(L))=SURF_DOWN_CLR_G(L) SWRAD3A.914
ENDDO SWRAD3A.915
ENDIF SWRAD3A.916
! SWRAD3A.917
! SWRAD3A.918
! CLEAR-SKY UPWARD FLUX AT THE SURFACE: SWRAD3A.919
! SWRAD3A.920
IF (L_SURF_UP_CLR) THEN SWRAD3A.921
CALL R2_ZERO_1D(N_PROFILE, SURF_UP_CLR) SWRAD3A.922
DO L=1, NLIT SWRAD3A.923
SURF_UP_CLR(LIST(L))=SURF_UP_CLR_G(L) SWRAD3A.924
ENDDO SWRAD3A.925
ENDIF SWRAD3A.926
! SWRAD3A.927
! SWRAD3A.928
! NET FLUX AT THE TROPOPAUSE: ADB2F404.1649
! ADB2F404.1650
IF (L_NET_FLUX_TROP) THEN ADB2F404.1651
CALL R2_ZERO_1D(N_PROFILE, NET_FLUX_TROP) ADB2F404.1652
DO L=1, NLIT ADB2F404.1653
NET_FLUX_TROP(LIST(L)) ADB2F404.1654
& =FLUX_NET(L, NLEVS+1-TRINDX(LIST(L))) ADB2F404.1655
ENDDO ADB2F404.1656
ENDIF ADB2F404.1657
! SWRAD3A.929
! SWRAD3A.930
! UPWARD FLUX AT THE TROPOPAUSE: ADB2F404.1658
! ADB2F404.1659
IF (L_UP_FLUX_TROP) THEN ADB2F404.1660
CALL R2_ZERO_1D(N_PROFILE, UP_FLUX_TROP) ADB1F405.973
DO L=1, NLIT ADB1F405.974
UP_FLUX_TROP(LIST(L)) ADB1F405.975
& =FLUX_UP(L, NLEVS+1-TRINDX(LIST(L))) ADB1F405.976
ENDDO ADB1F405.977
ENDIF ADB2F404.1685
! ADB2F404.1686
! ADB2F404.1687
! ADB2F404.1688
! ADB2F404.1689
! ADB2F404.1690
! FINAL PROCESSING OF OUTPUT FIELDS SWRAD3A.931
! SWRAD3A.932
! CONVERT THE FLUXES TO INCREMENTS. SWRAD3A.933
DO I=NLEVS, 1, -1 SWRAD3A.934
! SWRAD3A.935
DACON=(AB(I)-AB(I+1))*CPBYG/PTS SWRAD3A.936
DBCON=(BB(I)-BB(I+1))*CPBYG/PTS SWRAD3A.937
DO L=1, N_PROFILE SWRAD3A.938
SWOUT(L, I+1)=(SWOUT(L, I+1)-SWOUT(L, I)) SWRAD3A.939
& /(DACON+PSTAR(L)*DBCON) SWRAD3A.940
ENDDO SWRAD3A.941
! SWRAD3A.942
IF (L_CLEAR_HR) THEN SWRAD3A.943
DO L=1, NLIT SWRAD3A.944
CLEAR_HR(LIST(L), I)=(FLUX_NET_CLEAR(L, NLEVS-I) SWRAD3A.945
& -FLUX_NET_CLEAR(L, NLEVS+1-I)) SWRAD3A.946
& /(PTS*(DACON+PSTAR(LIST(L))*DBCON)) SWRAD3A.947
ENDDO SWRAD3A.948
ENDIF SWRAD3A.949
! SWRAD3A.950
ENDDO SWRAD3A.951
! SWRAD3A.952
! SWRAD3A.953
! SWRAD3A.954
! SEPARATE CONTRIBUTIONS OVER OPEN SEA. SWRAD3A.955
! SEA_FLUX_G IS NOT WEIGHTED BY THE FRACTION OF ICE. SWRAD3A.956
CALL R2_ZERO_1D(N_PROFILE, SWSEA) SWRAD3A.957
CDIR$ IVDEP SWRAD3A.958
! Fujitsu vectorization directive GRB0F405.551
!OCL NOVREC GRB0F405.552
DO L=1, NLIT SWRAD3A.959
IF (.NOT.LAND(LIST(L))) THEN SWRAD3A.960
SWSEA(LIST(L))=(1.0E+00-ICE_FRACTION(LIST(L))) SWRAD3A.961
& *SEA_FLUX_G(L) SWRAD3A.962
SWOUT(LIST(L), 1)=SWOUT(LIST(L), 1)-SWSEA(LIST(L)) SWRAD3A.963
ENDIF SWRAD3A.964
ENDDO SWRAD3A.965
! SWRAD3A.966
! SWRAD3A.967
! DIVIDE FLUX_BELOW_690NM_SURF BY LAND ALBEDO TO GIVE TOTAL AJS1F401.1424
! DOWNWARD FLUX OF PHOTOSYTHETICALLY ACTIVE RADIATION. ADD THIS AJS1F401.1425
! TO THE SWOUT ARRAY AS AN EXTRA 'LEVEL' TO ENABLE USE IN NON- AJS1F401.1426
! RADIATION TIMESTEPS. AJS1F401.1427
IF (L_FLUX_BELOW_690NM_SURF) THEN AJS1F401.1428
DO L=1, N_PROFILE AJS1F401.1429
SWOUT(L, NLEVS+2)=FLUX_BELOW_690NM_SURF(L) / AJS1F401.1430
& (1 - LAND_ICE_ALBEDO(L)) AJS1F401.1431
ENDDO AJS1F401.1432
ELSE AJS1F401.1433
DO L=1, N_PROFILE AJS1F401.1434
SWOUT(L, NLEVS+2)=0.0 AJS1F401.1435
ENDDO AJS1F401.1436
ENDIF AJS1F401.1437
! AJS1F401.1438
! AJS1F401.1439
! DIVIDE BY COSINE OF SOLAR ZENITH ANGLE TO PROVIDE VALUES FOR SWRAD3A.968
! UPPER ROUTINES. THIS APPLIES ONLY TO SWOUT. THE MACHINE TOLERANCE SWRAD3A.969
! IS ADDED TO MAINTAIN CONDITIONING. SWRAD3A.970
DO I=1, NLEVS+2 AJS1F401.1440
DO L=1, N_PROFILE SWRAD3A.972
SWOUT(L, I)=SWOUT(L, I)/(COSZIN(L)*LIT(L)+TOL_MACHINE) ADB1F401.1114
ENDDO SWRAD3A.974
ENDDO SWRAD3A.975
! SWRAD3A.976
! SWRAD3A.977
! SWRAD3A.978
RETURN SWRAD3A.979
END SWRAD3A.980
!+ Subroutine to set surface fields. SWRAD3A.981
! SWRAD3A.982
! Purpose: SWRAD3A.983
! The albedos and emissivity of the surface are set. SWRAD3A.984
! SWRAD3A.985
! Method: SWRAD3A.986
! Straightforward. Though the arrays passed to the code may depend SWRAD3A.987
! on the spectral band, the input arrays have no spectral dependence. SWRAD3A.988
! SWRAD3A.989
! Current Owner of Code: J. M. Edwards SWRAD3A.990
! SWRAD3A.991
! History: SWRAD3A.992
! Version Date Comment SWRAD3A.993
! 4.0 27-07-95 Original Code SWRAD3A.994
! (J. M. Edwards) SWRAD3A.995
! SWRAD3A.996
! Description of Code: SWRAD3A.997
! FORTRAN 77 with extensions listed in documentation. SWRAD3A.998
! SWRAD3A.999
!- --------------------------------------------------------------------- SWRAD3A.1000
SUBROUTINE R2_SET_SURFACE_FIELD_SW( 1SWRAD3A.1001
& N_BAND SWRAD3A.1002
& , NLIT, LIST SWRAD3A.1003
& , I_SURFACE, I_SPEC_SURFACE, L_SURFACE SWRAD3A.1004
& , L_MICROPHYSICS, L_SNOW_ALBEDO, SAL_DIM ARE2F404.273
& , LAND, OPEN_SEA_ALBEDO, LAND_ICE_ALBEDO, ICE_FRACTION SWRAD3A.1006
& , SAL_VIS, SAL_NIR, WEIGHT_690NM ARE2F404.274
& , EMISSIVITY_FIELD, ALBEDO_FIELD_DIR, ALBEDO_FIELD_DIFF SWRAD3A.1007
& , LAND_G, ALBEDO_SEA_DIFF, ALBEDO_SEA_DIR SWRAD3A.1008
& , NPD_FIELD, NPD_PROFILE, NPD_BAND_SW, NPD_SURFACE_SW ADB2F404.1691
& ) SWRAD3A.1010
! SWRAD3A.1011
! SWRAD3A.1012
! SWRAD3A.1013
IMPLICIT NONE SWRAD3A.1014
! SWRAD3A.1015
! SWRAD3A.1016
! COMDECKS INCLUDED SWRAD3A.1017
*CALL SRFSP3A SWRAD3A.1018
! SWRAD3A.1019
! DUMMY VARIABLES: SWRAD3A.1020
! SWRAD3A.1021
! DIMENSIONS OF ARRAYS: SWRAD3A.1022
INTEGER !, INTENT(IN) SWRAD3A.1023
& NPD_FIELD SWRAD3A.1024
! SIZE OF INPUT FIELDS SWRAD3A.1025
& , NPD_PROFILE SWRAD3A.1026
! MAXIMUM NUMBER OF ATMOSPHERIC PROFILES SWRAD3A.1027
& , NPD_BAND_SW ADB2F404.1692
! MAXIMUM NUMBER OF SPECTRAL BANDS SWRAD3A.1029
& , NPD_SURFACE_SW ADB2F404.1693
! MAXIMUM NUMBER OF SURFACES SWRAD3A.1031
! SWRAD3A.1032
! ACTUAL SIZES USED: SWRAD3A.1033
INTEGER !, INTENT(IN) SWRAD3A.1034
& N_BAND SWRAD3A.1035
! NUMBER OF SPECTRAL BANDS SWRAD3A.1036
& , SAL_DIM ARE2F404.275
! DIMENSION OF SAL_VIS AND SAL_NIR ARE2F404.276
! SWRAD3A.1037
! LIT POINTS: SWRAD3A.1038
INTEGER !, INTENT(IN) SWRAD3A.1039
& NLIT SWRAD3A.1040
! NUMBER OF LIT POINTS SWRAD3A.1041
& , LIST(NPD_FIELD) SWRAD3A.1042
! LIST OF SUNLIT POINTS SWRAD3A.1043
! SWRAD3A.1044
! PROPERTIES OF SURFACES SWRAD3A.1045
INTEGER !, INTENT(OUT) SWRAD3A.1046
& I_SURFACE(NPD_PROFILE) SWRAD3A.1047
! TYPES OF SURFACES SWRAD3A.1048
& , I_SPEC_SURFACE(NPD_SURFACE_SW) ADB2F404.1694
LOGICAL !, INTENT(OUT) SWRAD3A.1050
& L_SURFACE(NPD_SURFACE_SW) ADB2F404.1695
! FLAGS FOR TYPES OF SURFACES SWRAD3A.1052
! SWRAD3A.1053
! PHYSICAL PROPERTIES OF SURFACES: SWRAD3A.1054
LOGICAL !, INTENT(IN) SWRAD3A.1055
& LAND(NPD_FIELD) SWRAD3A.1056
! LAND MASK SWRAD3A.1057
REAL !, INTENT(IN) SWRAD3A.1058
& OPEN_SEA_ALBEDO(NPD_FIELD, 2) SWRAD3A.1059
! DIFFUSE ALBEDO FIELD SWRAD3A.1060
& , LAND_ICE_ALBEDO(NPD_FIELD) SWRAD3A.1061
! DIRECT ALBEDO FIELD SWRAD3A.1062
& , SAL_VIS(SAL_DIM,2) ARE2F404.277
! VISIBLE ALBEDO FIELD ARE2F404.278
& , SAL_NIR(SAL_DIM,2) ARE2F404.279
! NEAR-IR ALBEDO FIELD ARE2F404.280
& , WEIGHT_690NM(NPD_BAND_SW) ARE2F404.281
! WEIGHTS FOR EACH BAND FOR REGION BELOW 690 NM ARE2F404.282
& , ICE_FRACTION(NPD_FIELD) SWRAD3A.1063
! FRACTION OF SEA ICE SWRAD3A.1064
! SWRAD3A.1065
! MISCELLANEOUS INPUTS SWRAD3A.1066
LOGICAL !, INTENT(IN) SWRAD3A.1067
& L_MICROPHYSICS SWRAD3A.1068
! FLAG TO CALCULATE MICROPHYSICS SWRAD3A.1069
& , L_SNOW_ALBEDO ARE2F404.283
! FLAG FOR PROGNOSTIC SNOW ALBEDO ARE2F404.284
! SWRAD3A.1070
! SWRAD3A.1071
! SURFACE PROPERTIES SET. SWRAD3A.1072
REAL !, INTENT(OUT) SWRAD3A.1073
& EMISSIVITY_FIELD(NPD_PROFILE, NPD_BAND_SW) ADB2F404.1696
! EMISSIVITIES OF SURFACES SWRAD3A.1075
& , ALBEDO_FIELD_DIFF(NPD_PROFILE, NPD_BAND_SW) ADB2F404.1697
! DIFFUSE ALBEDO OF SURFACE SWRAD3A.1077
& , ALBEDO_FIELD_DIR(NPD_PROFILE, NPD_BAND_SW) ADB2F404.1698
! DIRECT ALBEDO OF SURFACE SWRAD3A.1079
! SWRAD3A.1080
! GATHERED SURFACE FIELDS SWRAD3A.1081
LOGICAL !, INTENT(OUT) SWRAD3A.1082
& LAND_G(NPD_PROFILE) SWRAD3A.1083
! GATHERED LAND FLAGS SWRAD3A.1084
REAL !, INTENT(OUT) SWRAD3A.1085
& ALBEDO_SEA_DIFF(NPD_PROFILE, NPD_BAND_SW) ADB2F404.1699
! DIFFUSE ALBEDO OF OPEN SEA SWRAD3A.1087
& , ALBEDO_SEA_DIR(NPD_PROFILE, NPD_BAND_SW) ADB2F404.1700
! DIRECT ALBEDO OF OPEN SEA SWRAD3A.1089
! SWRAD3A.1090
! SWRAD3A.1091
! LOCAL VARIABLES. SWRAD3A.1092
INTEGER SWRAD3A.1093
& I SWRAD3A.1094
! LOOP VARIABLE SWRAD3A.1095
& , L SWRAD3A.1096
! LOOP VARIABLE SWRAD3A.1097
! SWRAD3A.1098
! SWRAD3A.1099
! SWRAD3A.1100
! OVERRIDE ANY SURFACE PROERTIES READ IN FROM THE SPECTRAL FILE. SWRAD3A.1101
DO L=1, NLIT SWRAD3A.1102
I_SURFACE(L)=1 SWRAD3A.1103
ENDDO SWRAD3A.1104
L_SURFACE(1)=.TRUE. SWRAD3A.1105
I_SPEC_SURFACE(1)=IP_SURFACE_INTERNAL SWRAD3A.1106
! SWRAD3A.1107
! SWRAD3A.1108
IF (L_MICROPHYSICS) THEN SWRAD3A.1109
! GATHER THE ARRAY OF SURFACE FLAGS IF THE MICROPHYSICS SWRAD3A.1110
! IS PARAMETRIZED. SWRAD3A.1111
DO L=1, NLIT SWRAD3A.1112
LAND_G(L)=LAND(LIST(L)) SWRAD3A.1113
ENDDO SWRAD3A.1114
ENDIF SWRAD3A.1115
! SWRAD3A.1116
! SWRAD3A.1117
! SET THE ALBEDO FIELDS: AN AVERAGE ALBEDO IS REQUIRED OVER WHERE SWRAD3A.1118
! THERE IS SEA-ICE. SEPARATE ALBEDOS ARE PROVIDED FOR LAND/ICE SWRAD3A.1119
! OR FOR OPEN SEA. BAND-DEPENDENT COPIES OF THE ALBEDOS MUST BE SWRAD3A.1120
! MADE FOR CALCULATING COUPLING FLUXES. SWRAD3A.1121
! SWRAD3A.1122
DO I=1, N_BAND SWRAD3A.1123
DO L=1, NLIT SWRAD3A.1124
! SWRAD3A.1125
EMISSIVITY_FIELD(L, I)=0.0E+00 SWRAD3A.1126
! SWRAD3A.1127
IF (.NOT.LAND(LIST(L))) THEN SWRAD3A.1128
ALBEDO_FIELD_DIFF(L, I) SWRAD3A.1129
& =LAND_ICE_ALBEDO(LIST(L))*ICE_FRACTION(LIST(L)) SWRAD3A.1130
& +OPEN_SEA_ALBEDO(LIST(L), 2) SWRAD3A.1131
& *(1.0E+00-ICE_FRACTION(LIST(L))) SWRAD3A.1132
ALBEDO_FIELD_DIR(L, I) SWRAD3A.1133
& =LAND_ICE_ALBEDO(LIST(L))*ICE_FRACTION(LIST(L)) SWRAD3A.1134
& +OPEN_SEA_ALBEDO(LIST(L), 1) SWRAD3A.1135
& *(1.0E+00-ICE_FRACTION(LIST(L))) SWRAD3A.1136
ALBEDO_SEA_DIR(L, I)=OPEN_SEA_ALBEDO(LIST(L), 1) SWRAD3A.1137
ALBEDO_SEA_DIFF(L, I)=OPEN_SEA_ALBEDO(LIST(L), 2) SWRAD3A.1138
ELSE SWRAD3A.1139
IF ( L_SNOW_ALBEDO ) THEN ARE2F404.285
ALBEDO_FIELD_DIFF(L,I) = ARE2F404.286
& WEIGHT_690NM(I)*SAL_VIS(LIST(L),2) ARE2F404.287
& + (1. - WEIGHT_690NM(I))*SAL_NIR(LIST(L),2) ARE2F404.288
ALBEDO_FIELD_DIR(L,I) = ARE2F404.289
& WEIGHT_690NM(I)*SAL_VIS(LIST(L),1) ARE2F404.290
& + (1. - WEIGHT_690NM(I))*SAL_NIR(LIST(L),1) ARE2F404.291
ELSE ARE2F404.292
ALBEDO_FIELD_DIFF(L, I)=LAND_ICE_ALBEDO(LIST(L)) SWRAD3A.1140
ALBEDO_FIELD_DIR(L, I)=LAND_ICE_ALBEDO(LIST(L)) SWRAD3A.1141
ENDIF ARE2F404.293
ALBEDO_SEA_DIR(L, I)=0.0E+00 SWRAD3A.1142
ALBEDO_SEA_DIFF(L, I)=0.0E+00 SWRAD3A.1143
ENDIF SWRAD3A.1144
! SWRAD3A.1145
ENDDO SWRAD3A.1146
ENDDO SWRAD3A.1147
! SWRAD3A.1148
! SWRAD3A.1149
! SWRAD3A.1150
RETURN SWRAD3A.1151
END SWRAD3A.1152
!+ Subroutine to calculate weights for the flux below 690 nm. SWRAD3A.1153
! SWRAD3A.1154
! Purpose: SWRAD3A.1155
! Weights to calculate the flux below 690 nm are set. SWRAD3A.1156
! SWRAD3A.1157
! Method: SWRAD3A.1158
! Straightforward. The flux is assumed to be linearly distributed SWRAD3A.1159
! across bands. SWRAD3A.1160
! SWRAD3A.1161
! Current Owner of Code: J. M. Edwards SWRAD3A.1162
! SWRAD3A.1163
! History: SWRAD3A.1164
! Version Date Comment SWRAD3A.1165
! 4.0 27-07-95 Original Code SWRAD3A.1166
! (J. M. Edwards) SWRAD3A.1167
! SWRAD3A.1168
! Description of Code: SWRAD3A.1169
! FORTRAN 77 with extensions listed in documentation. SWRAD3A.1170
! SWRAD3A.1171
!- --------------------------------------------------------------------- SWRAD3A.1172
SUBROUTINE R2_SET_690NM_WEIGHT(N_BAND 1SWRAD3A.1173
& , L_PRESENT ADB1F401.1115
& , N_BAND_EXCLUDE, INDEX_EXCLUDE SWRAD3A.1174
& , WAVE_LENGTH_SHORT, WAVE_LENGTH_LONG SWRAD3A.1175
& , WEIGHT_690NM SWRAD3A.1176
& , NPD_BAND_SW, NPD_EXCLUDE_SW, NPD_TYPE_SW ADB2F404.1701
& ) SWRAD3A.1178
! SWRAD3A.1179
! SWRAD3A.1180
! SWRAD3A.1181
IMPLICIT NONE SWRAD3A.1182
! SWRAD3A.1183
! SWRAD3A.1184
! DUMMY VARIABLES: SWRAD3A.1185
! SWRAD3A.1186
! DIMENSIONS OF ARRAYS: SWRAD3A.1187
INTEGER !, INTENT(IN) SWRAD3A.1188
& NPD_BAND_SW ADB2F404.1702
! MAXIMUM NUMBER OF SPECTRAL BANDS SWRAD3A.1190
& , NPD_EXCLUDE_SW ADB2F404.1703
! MAXIMUM NUMBER OF EXCLUDED REGIONS SWRAD3A.1192
& , NPD_TYPE_SW ADB2F404.1704
! MAXIMUM NUMBER OF TYPES OF SPECTRAL DATA ADB1F401.1118
! SWRAD3A.1193
! ACTUAL SIZES USED: SWRAD3A.1194
INTEGER !, INTENT(IN) SWRAD3A.1195
& N_BAND SWRAD3A.1196
! NUMBER OF SPECTRAL BANDS SWRAD3A.1197
& , N_BAND_EXCLUDE(NPD_BAND_SW) ADB2F404.1705
! NUMBER OF EXCLUDED REGIONS IN BANDS SWRAD3A.1199
& , INDEX_EXCLUDE(NPD_EXCLUDE_SW, NPD_BAND_SW) ADB2F404.1706
! INDICES OF EXCLUDED REGIONS IN BANDS SWRAD3A.1201
! SWRAD3A.1202
LOGICAL !, INTENT(IN) ADB1F401.1119
& L_PRESENT(0: NPD_TYPE_SW) ADB2F404.1707
! FLAG FOR TYPES OF SPECTRAL DATA PRESENT ADB1F401.1121
! ADB1F402.731
REAL !, INTENT(IN) SWRAD3A.1203
& WAVE_LENGTH_SHORT(NPD_BAND_SW) ADB2F404.1708
! SHORT WAVELENGTH LIMITS OF BANDS SWRAD3A.1205
& , WAVE_LENGTH_LONG(NPD_BAND_SW) ADB2F404.1709
! LONG WAVELENGTH LIMITS OF BANDS SWRAD3A.1207
! SWRAD3A.1208
! SWRAD3A.1209
! WEIGHTS SET. SWRAD3A.1210
REAL !, INTENT(OUT) SWRAD3A.1211
& WEIGHT_690NM(NPD_BAND_SW) ADB2F404.1710
! WEIGHTS APPLYING TO EACH BAND SWRAD3A.1213
! SWRAD3A.1214
! LOCAL VARIABLES. SWRAD3A.1215
INTEGER SWRAD3A.1216
& I SWRAD3A.1217
! LOOP VARIABLE SWRAD3A.1218
& , J SWRAD3A.1219
! LOOP VARIABLE SWRAD3A.1220
REAL SWRAD3A.1221
& TOTAL_ENERGY_RANGE SWRAD3A.1222
! TOTAL RANGE OF ENERGIES COVERED BY BAND SWRAD3A.1223
& , ENERGY_RANGE_BELOW_690NM SWRAD3A.1224
! RANGE OF ENERGIES IN BAND BELOW 690 NM SWRAD3A.1225
! SWRAD3A.1226
! SWRAD3A.1227
! SWRAD3A.1228
DO I=1, N_BAND SWRAD3A.1229
IF (WAVE_LENGTH_LONG(I).LT.6.9E-07) THEN SWRAD3A.1230
WEIGHT_690NM(I)=1.0E+00 SWRAD3A.1231
ELSE IF (WAVE_LENGTH_SHORT(I).GT.6.9E-07) THEN SWRAD3A.1232
WEIGHT_690NM(I)=0.0E+00 SWRAD3A.1233
ELSE SWRAD3A.1234
! SWRAD3A.1235
ENERGY_RANGE_BELOW_690NM=1.0E+00/WAVE_LENGTH_SHORT(I) SWRAD3A.1236
& -1.0E+00/6.9E-07 SWRAD3A.1237
TOTAL_ENERGY_RANGE=1.0E+00/WAVE_LENGTH_SHORT(I) SWRAD3A.1238
& -1.0E+00/WAVE_LENGTH_LONG(I) SWRAD3A.1239
IF (L_PRESENT(14)) THEN ADB1F401.1122
! REMOVE CONTRIBUTIONS FROM EXCLUDED BANDS. ADB1F402.732
DO J=1, N_BAND_EXCLUDE(I) ADB1F402.733
IF (WAVE_LENGTH_LONG(INDEX_EXCLUDE(J, I)).LT. ADB1F402.734
& 6.9E-07) THEN ADB1F402.735
ENERGY_RANGE_BELOW_690NM=ENERGY_RANGE_BELOW_690NM ADB1F402.736
& -1.0E+00/WAVE_LENGTH_SHORT(INDEX_EXCLUDE(J, I)) ADB1F402.737
& +1.0E+00/WAVE_LENGTH_LONG(INDEX_EXCLUDE(J, I)) ADB1F402.738
ELSE IF (WAVE_LENGTH_SHORT(INDEX_EXCLUDE(J, I)).LT. ADB1F402.739
& 6.9E-07) THEN ADB1F402.740
ENERGY_RANGE_BELOW_690NM=ENERGY_RANGE_BELOW_690NM ADB1F402.741
& -1.0E+00/WAVE_LENGTH_SHORT(INDEX_EXCLUDE(J, I)) ADB1F402.742
& +1.0E+00/6.9E-07 ADB1F402.743
ENDIF ADB1F402.744
TOTAL_ENERGY_RANGE=TOTAL_ENERGY_RANGE ADB1F402.745
& -1.0E+00/WAVE_LENGTH_SHORT(INDEX_EXCLUDE(J, I)) SWRAD3A.1245
& +1.0E+00/WAVE_LENGTH_LONG(INDEX_EXCLUDE(J, I)) SWRAD3A.1246
ENDDO ADB1F402.746
ENDIF ADB1F401.1123
! SWRAD3A.1257
WEIGHT_690NM(I)=ENERGY_RANGE_BELOW_690NM/TOTAL_ENERGY_RANGE SWRAD3A.1258
! SWRAD3A.1259
ENDIF SWRAD3A.1260
! SWRAD3A.1261
ENDDO SWRAD3A.1262
! SWRAD3A.1263
! SWRAD3A.1264
! SWRAD3A.1265
RETURN SWRAD3A.1266
END SWRAD3A.1267
!+ Subroutine to initialize diagnostics for MRF/UMIST parametrization. SWRAD3A.1268
! SWRAD3A.1269
! Purpose: SWRAD3A.1270
! Checks are made for consistency of the diagnostic requests and the SWRAD3A.1271
! arrays are filled with zeros at all points. SWRAD3A.1272
! SWRAD3A.1273
! Method: SWRAD3A.1274
! Straightforward. SWRAD3A.1275
! SWRAD3A.1276
! Current Owner of Code: J. M. Edwards SWRAD3A.1277
! SWRAD3A.1278
! History: SWRAD3A.1279
! Version Date Comment SWRAD3A.1280
! 4.0 27-07-95 Original Code SWRAD3A.1281
! (J. M. Edwards) SWRAD3A.1282
! SWRAD3A.1283
! Description of Code: SWRAD3A.1284
! FORTRAN 77 with extensions listed in documentation. SWRAD3A.1285
! SWRAD3A.1286
!- --------------------------------------------------------------------- SWRAD3A.1287
SUBROUTINE R2_INIT_MRF_UMIST_DIAG(IERR 1,9SWRAD3A.1288
& , RE_CONV, RE_CONV_FLAG, RE_STRAT, RE_STRAT_FLAG SWRAD3A.1289
& , WGT_CONV, WGT_CONV_FLAG, WGT_STRAT, WGT_STRAT_FLAG SWRAD3A.1290
& , LWP_STRAT, LWP_STRAT_FLAG SWRAD3A.1291
& , NTOT_DIAG, NTOT_DIAG_FLAG AAJ3F404.57
& , STRAT_LWC_DIAG, STRAT_LWC_DIAG_FLAG AAJ3F404.58
& , SO4_CCN_DIAG, SO4_CCN_DIAG_FLAG AAJ3F404.59
& , COND_SAMP_WGT, COND_SAMP_WGT_FLAG AAJ3F404.60
& , NPD_FIELD, N_PROFILE, NCLDS SWRAD3A.1292
& ) SWRAD3A.1293
! SWRAD3A.1294
! SWRAD3A.1295
! SWRAD3A.1296
IMPLICIT NONE SWRAD3A.1297
! SWRAD3A.1298
! SWRAD3A.1299
! COMDECKS INCLUDED SWRAD3A.1300
*CALL ERROR3A SWRAD3A.1301
*CALL STDIO3A SWRAD3A.1302
! SWRAD3A.1303
! DUMMY VARIABLES: SWRAD3A.1304
! SWRAD3A.1305
! ERROR FLAG SWRAD3A.1306
INTEGER !, INTENT(OUT) SWRAD3A.1307
& IERR SWRAD3A.1308
! ERROR FLAG SWRAD3A.1309
! SWRAD3A.1310
! DIMENSIONS OF ARRAYS: SWRAD3A.1311
INTEGER !, INTENT(IN) SWRAD3A.1312
& NPD_FIELD SWRAD3A.1313
! ACTUAL SIZE OF INPUT ARRAY SWRAD3A.1314
! SWRAD3A.1315
! SIZES USED: SWRAD3A.1316
INTEGER !, INTENT(IN) SWRAD3A.1317
& N_PROFILE SWRAD3A.1318
! NUMBER OF PROFILES SWRAD3A.1319
& , NCLDS SWRAD3A.1320
! NUMBER OF CLOUDY LEVELS SWRAD3A.1321
SWRAD3A.1322
! DIAGNOSTICS FOR THE MRF/UMIST PARAMETRIZATION SWRAD3A.1323
! SWRAD3A.1324
LOGICAL SWRAD3A.1325
& RE_CONV_FLAG SWRAD3A.1326
! DIAGNOSE EFFECTIVE RADIUS*WEIGHT FOR CONVECTIVE CLOUD SWRAD3A.1327
& , RE_STRAT_FLAG SWRAD3A.1328
! DIAGNOSE EFFECTIVE RADIUS*WEIGHT FOR STRATIFORM CLOUD SWRAD3A.1329
& , WGT_CONV_FLAG SWRAD3A.1330
! DIAGNOSE WEIGHT FOR CONVECTIVE CLOUD SWRAD3A.1331
& , WGT_STRAT_FLAG SWRAD3A.1332
! DIAGNOSE WEIGHT FOR STRATIFORM CLOUD SWRAD3A.1333
& , LWP_STRAT_FLAG SWRAD3A.1334
! DIAGNOSE LIQUID WATER PATH*WEIGHT FOR STRATIFORM CLOUD SWRAD3A.1335
& , NTOT_DIAG_FLAG AAJ3F404.61
! DIAGNOSE DROPLET CONCENTRATION*WEIGHT AAJ3F404.62
& , STRAT_LWC_DIAG_FLAG AAJ3F404.63
! DIAGNOSE STRATIFORM LWC*WEIGHT AAJ3F404.64
& , SO4_CCN_DIAG_FLAG AAJ3F404.65
! DIAGNOSE SO4 CCN MASS CONC*COND. SAMP. WEIGHT AAJ3F404.66
& , COND_SAMP_WGT_FLAG AAJ3F404.67
! DIAGNOSE CONDITIONAL SAMPLING WEIGHT AAJ3F404.68
! SWRAD3A.1336
REAL SWRAD3A.1337
& RE_CONV(NPD_FIELD, NCLDS) SWRAD3A.1338
! EFFECTIVE RADIUS*WEIGHT FOR CONVECTIVE CLOUD SWRAD3A.1339
& , RE_STRAT(NPD_FIELD, NCLDS) SWRAD3A.1340
! EFFECTIVE RADIUS*WEIGHT FOR STRATIFORM CLOUD SWRAD3A.1341
& , WGT_CONV(NPD_FIELD, NCLDS) SWRAD3A.1342
! WEIGHT FOR CONVECTIVE CLOUD SWRAD3A.1343
& , WGT_STRAT(NPD_FIELD, NCLDS) SWRAD3A.1344
! WEIGHT FOR STRATIFORM CLOUD SWRAD3A.1345
& , LWP_STRAT(NPD_FIELD, NCLDS) SWRAD3A.1346
! LIQUID WATER PATH*WEIGHT FOR STRATIFORM CLOUD SWRAD3A.1347
& , NTOT_DIAG(NPD_FIELD, NCLDS) AAJ3F404.69
! DROPLET CONCENTRATION*WEIGHT AAJ3F404.70
& , STRAT_LWC_DIAG(NPD_FIELD, NCLDS) AAJ3F404.71
! STRATIFORM LWC*WEIGHT AAJ3F404.72
& , SO4_CCN_DIAG(NPD_FIELD, NCLDS) AAJ3F404.73
! SO4 CCN MASS CONC*COND. SAMP. WEIGHT AAJ3F404.74
& , COND_SAMP_WGT(NPD_FIELD, NCLDS) AAJ3F404.75
! CONDITIONAL SAMPLING WEIGHT AAJ3F404.76
! SWRAD3A.1348
! SWRAD3A.1349
! LOCAL VARIABLES. SWRAD3A.1350
INTEGER SWRAD3A.1351
& I SWRAD3A.1352
! LOOP VARIABLE SWRAD3A.1353
! SWRAD3A.1354
! SWRAD3A.1355
! SWRAD3A.1356
IF (RE_CONV_FLAG) THEN SWRAD3A.1357
IF (.NOT.WGT_CONV_FLAG) THEN SWRAD3A.1358
WRITE(IU_ERR, '(/A, /A)') SWRAD3A.1359
& '*** ERROR: MICROPHYSICAL DIAGNOSTICS FOR CONVECTIVE' SWRAD3A.1360
& , 'CLOUD MUST INCLUDE THE CLOUD WEIGHTING.' SWRAD3A.1361
IERR=I_ERR_FATAL SWRAD3A.1362
RETURN SWRAD3A.1363
ENDIF SWRAD3A.1364
ENDIF SWRAD3A.1365
! SWRAD3A.1366
IF ( (RE_STRAT_FLAG).OR.(LWP_STRAT_FLAG) ) THEN SWRAD3A.1367
IF (.NOT.WGT_STRAT_FLAG) THEN SWRAD3A.1368
WRITE(IU_ERR, '(/A, /A)') SWRAD3A.1369
& '*** ERROR: MICROPHYSICAL DIAGNOSTICS FOR STRATIFORM' SWRAD3A.1370
& , 'CLOUD MUST INCLUDE THE CLOUD WEIGHTING.' SWRAD3A.1371
IERR=I_ERR_FATAL SWRAD3A.1372
RETURN SWRAD3A.1373
ENDIF SWRAD3A.1374
ENDIF SWRAD3A.1375
! SWRAD3A.1376
! SWRAD3A.1377
DO I=1, NCLDS SWRAD3A.1378
IF (WGT_CONV_FLAG) SWRAD3A.1379
& CALL R2_ZERO_1D(N_PROFILE, WGT_CONV(1, I)) SWRAD3A.1380
IF (RE_CONV_FLAG) SWRAD3A.1381
& CALL R2_ZERO_1D(N_PROFILE, RE_CONV(1, I)) SWRAD3A.1382
IF (WGT_STRAT_FLAG) SWRAD3A.1383
& CALL R2_ZERO_1D(N_PROFILE, WGT_STRAT(1, I)) SWRAD3A.1384
IF (RE_STRAT_FLAG) SWRAD3A.1385
& CALL R2_ZERO_1D(N_PROFILE, RE_STRAT(1, I)) SWRAD3A.1386
IF (LWP_STRAT_FLAG) SWRAD3A.1387
& CALL R2_ZERO_1D(N_PROFILE, LWP_STRAT(1, I)) SWRAD3A.1388
IF (NTOT_DIAG_FLAG) AAJ3F404.77
& CALL R2_ZERO_1D(N_PROFILE, NTOT_DIAG(1, I)) AAJ3F404.78
IF (STRAT_LWC_DIAG_FLAG) AAJ3F404.79
& CALL R2_ZERO_1D(N_PROFILE, STRAT_LWC_DIAG(1, I)) AAJ3F404.80
IF (SO4_CCN_DIAG_FLAG) AAJ3F404.81
& CALL R2_ZERO_1D(N_PROFILE, SO4_CCN_DIAG(1, I)) AAJ3F404.82
IF (COND_SAMP_WGT_FLAG) AAJ3F404.83
& CALL R2_ZERO_1D(N_PROFILE, COND_SAMP_WGT(1, I)) AAJ3F404.84
ENDDO SWRAD3A.1389
! SWRAD3A.1390
! SWRAD3A.1391
! SWRAD3A.1392
RETURN SWRAD3A.1393
END SWRAD3A.1394
*ENDIF DEF,A01_3A SWRAD3A.1395