SUBROUTINE SOLVE_BAND_RANDOM_OVERLAP(IERR 1,6SBRV3A.20
! Atmospheric Column SBRV3A.21
& , N_PROFILE, N_LAYER, L_LAYER, I_TOP, P, T, D_MASS SBRV3A.22
! Angular Integration SBRV3A.23
& , I_ANGULAR_INTEGRATION, I_2STREAM, L_2_STREAM_CORRECT SBRV3A.24
& , L_RESCALE, N_ORDER_GAUSS SBRV3A.25
! Treatment of Scattering SBRV3A.26
& , I_SCATTER_METHOD_BAND SBRV3A.27
! Options for solver SBRV3A.28
& , I_SOLVER, L_NET, N_AUGMENT ADB1F405.587
! Gaseous Properties SBRV3A.30
& , I_BAND, N_GAS SBRV3A.31
& , INDEX_ABSORB, I_BAND_ESFT, I_SCALE_ESFT, I_SCALE_FNC SBRV3A.32
& , K_ESFT, W_ESFT, SCALE_VECTOR SBRV3A.33
& , P_REFERENCE, T_REFERENCE SBRV3A.34
& , GAS_MIX_RATIO, GAS_FRAC_RESCALED SBRV3A.35
& , L_DOPPLER, DOPPLER_CORRECTION SBRV3A.36
! Spectral Region SBRV3A.37
& , ISOLIR SBRV3A.38
! Solar Properties SBRV3A.39
& , SEC_0, SOLAR_FLUX SBRV3A.40
! Infra-red Properties SBRV3A.41
& , PLANCK_SOURCE_TOP, PLANCK_SOURCE_BOTTOM SBRV3A.42
& , DIFF_PLANCK_BAND SBRV3A.43
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_BAND_2 SBRV3A.44
! Surface Properties SBRV3A.45
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR, THERMAL_GROUND_BAND SBRV3A.46
! Clear-sky Optical Properties SBRV3A.47
& , K_GREY_TOT_FREE, K_EXT_SCAT_FREE, ASYMMETRY_FREE SBRV3A.48
& , FORWARD_SCATTER_FREE SBRV3A.49
! Cloudy Properties SBRV3A.50
& , L_CLOUD, I_CLOUD SBRV3A.51
! Cloud Geometry SBRV3A.52
& , N_CLOUD_TOP SBRV3A.53
& , N_CLOUD_TYPE, FRAC_CLOUD SBRV3A.54
& , I_REGION_CLOUD, FRAC_REGION ADB1F402.668
& , W_FREE, N_FREE_PROFILE, I_FREE_PROFILE SBRV3A.55
& , W_CLOUD, N_CLOUD_PROFILE, I_CLOUD_PROFILE SBRV3A.56
& , CLOUD_OVERLAP SBRV3A.57
& , N_COLUMN, L_COLUMN, AREA_COLUMN SBRV3A.58
! Cloudy Optical Properties SBRV3A.59
& , K_GREY_TOT_CLOUD, K_EXT_SCAT_CLOUD SBRV3A.60
& , ASYMMETRY_CLOUD, FORWARD_SCATTER_CLOUD SBRV3A.61
! Fluxes Calculated SBRV3A.62
& , FLUX_DIRECT_BAND, FLUX_TOTAL_BAND SBRV3A.63
! Flags for Clear-sky Fluxes SBRV3A.64
& , L_CLEAR, I_SOLVER_CLEAR SBRV3A.65
! Clear-sky Fluxes SBRV3A.66
& , FLUX_DIRECT_CLEAR_BAND, FLUX_TOTAL_CLEAR_BAND SBRV3A.67
! Planckian Function SBRV3A.68
& , PLANCK_SOURCE_BAND SBRV3A.69
& , NPD_PROFILE, NPD_LAYER, NPD_COLUMN SBRV3A.70
& , NPD_BAND, NPD_SPECIES SBRV3A.71
& , NPD_ESFT_TERM, NPD_SCALE_VARIABLE, NPD_SCALE_FNC SBRV3A.72
& ) SBRV3A.73
! SBRV3A.74
! SBRV3A.75
! SBRV3A.76
IMPLICIT NONE SBRV3A.77
! SBRV3A.78
! SBRV3A.79
! SIZES OF DUMMY ARRAYS. SBRV3A.80
INTEGER !, INTENT(IN) SBRV3A.81
& NPD_PROFILE SBRV3A.82
! MAXIMUM NUMBER OF PROFILES SBRV3A.83
& , NPD_LAYER SBRV3A.84
! MAXIMUM NUMBER OF LAYERS SBRV3A.85
& , NPD_BAND SBRV3A.86
! MAXIMUM NUMBER OF SPECTRAL BANDS SBRV3A.87
& , NPD_SPECIES SBRV3A.88
! MAXIMUM NUMBER OF SPECIES SBRV3A.89
& , NPD_ESFT_TERM SBRV3A.90
! MAXIMUM NUMBER OF ESFT TERMS SBRV3A.91
& , NPD_SCALE_VARIABLE SBRV3A.92
! MAXIMUM NUMBER OF SCALE VARIABLES SBRV3A.93
& , NPD_SCALE_FNC SBRV3A.94
! MAXIMUM NUMBER OF SCALING FUNCTIONS SBRV3A.95
& , NPD_COLUMN SBRV3A.96
! NUMBER OF COLUMNS PER POINT SBRV3A.97
! SBRV3A.98
! INCLUDE COMDECKS. SBRV3A.99
*CALL DIMFIX3A 
SBRV3A.100
*CALL ESFTSC3A SBRV3A.101
*CALL SPCRG3A SBRV3A.102
*CALL ERROR3A SBRV3A.103
! SBRV3A.104
! SBRV3A.105
! SBRV3A.106
! DUMMY ARGUMENTS. SBRV3A.107
INTEGER !, INTENT(OUT) SBRV3A.108
& IERR SBRV3A.109
! ERROR FLAG SBRV3A.110
! SBRV3A.111
! Atmospheric Column SBRV3A.112
INTEGER !, INTENT(IN) SBRV3A.113
& N_PROFILE SBRV3A.114
! NUMBER OF PROFILES SBRV3A.115
& , N_LAYER SBRV3A.116
! NUMBER OF LAYERS SBRV3A.117
& , I_TOP SBRV3A.118
! TOP OF VERTICAL GRID SBRV3A.119
LOGICAL !, INTENT(IN) SBRV3A.120
& L_LAYER SBRV3A.121
! PROPERTIES GIVEN IN LAYERS SBRV3A.122
REAL !, INTENT(IN) SBRV3A.123
& D_MASS(NPD_PROFILE, NPD_LAYER) SBRV3A.124
! MASS THICKNESS OF EACH LAYER SBRV3A.125
& , P(NPD_PROFILE, 0: NPD_LAYER) SBRV3A.126
! PRESSURE SBRV3A.127
& , T(NPD_PROFILE, 0: NPD_LAYER) SBRV3A.128
! TEMPERATURE SBRV3A.129
! SBRV3A.130
! Angular Integration SBRV3A.131
INTEGER !, INTENT(IN) SBRV3A.132
& I_ANGULAR_INTEGRATION SBRV3A.133
! ANGULAR INTEGRATION SCHEME SBRV3A.134
& , I_2STREAM SBRV3A.135
! TWO-STREAM SCHEME SBRV3A.136
& , N_ORDER_GAUSS SBRV3A.137
! ORDER OF GAUSSIAN INTEGRATION SBRV3A.138
LOGICAL !, INTENT(IN) SBRV3A.139
& L_2_STREAM_CORRECT SBRV3A.140
! USE AN EDGE CORRECTION SBRV3A.141
& , L_RESCALE SBRV3A.142
! RESCALE OPTICAL PROPERTIES SBRV3A.143
! SBRV3A.144
! Treatment of Scattering SBRV3A.145
INTEGER !, INTENT(IN) SBRV3A.146
& I_SCATTER_METHOD_BAND SBRV3A.147
! METHOD OF TREATING SCATTERING SBRV3A.148
! SBRV3A.149
! Options for Solver SBRV3A.150
INTEGER !, INTENT(IN) SBRV3A.151
& I_SOLVER SBRV3A.152
! SOLVER USED SBRV3A.153
& , N_AUGMENT SBRV3A.156
! LENGTH OF LONG FLUX VECTOR SBRV3A.157
LOGICAL !, INTENT(IN) SBRV3A.158
& L_NET SBRV3A.159
! SOLVE FOR NET FLUXES SBRV3A.160
! SBRV3A.161
! Gaseous Properties SBRV3A.162
INTEGER !, INTENT(IN) SBRV3A.163
& I_BAND SBRV3A.164
! BAND BEING CONSIDERED SBRV3A.165
& , N_GAS SBRV3A.166
! NUMBER OF GASES IN BAND SBRV3A.167
& , INDEX_ABSORB(NPD_SPECIES, NPD_BAND) SBRV3A.168
! LIST OF ABSORBERS IN BANDS SBRV3A.169
& , I_BAND_ESFT(NPD_BAND, NPD_SPECIES) SBRV3A.170
! NUMBER OF TERMS IN BAND SBRV3A.171
& , I_SCALE_ESFT(NPD_BAND, NPD_SPECIES) SBRV3A.172
! TYPE OF ESFT SCALING SBRV3A.173
& , I_SCALE_FNC(NPD_BAND, NPD_SPECIES) SBRV3A.174
! TYPE OF SCALING FUNCTION SBRV3A.175
LOGICAL !, INTENT(IN) SBRV3A.176
& L_DOPPLER(NPD_SPECIES) SBRV3A.177
! DOPPLER BROADENING INCLUDED SBRV3A.178
REAL !, INTENT(IN) SBRV3A.179
& K_ESFT(NPD_ESFT_TERM, NPD_BAND, NPD_SPECIES) SBRV3A.180
! EXPONENTIAL ESFT TERMS SBRV3A.181
& , W_ESFT(NPD_ESFT_TERM, NPD_BAND, NPD_SPECIES) SBRV3A.182
! WEIGHTS FOR ESFT SBRV3A.183
& , SCALE_VECTOR(NPD_SCALE_VARIABLE, NPD_ESFT_TERM, NPD_BAND SBRV3A.184
& , NPD_SPECIES) SBRV3A.185
! ABSORBER SCALING PARAMETERS SBRV3A.186
& , P_REFERENCE(NPD_SPECIES, NPD_BAND) SBRV3A.187
! REFERENCE SCALING PRESSURE SBRV3A.188
& , T_REFERENCE(NPD_SPECIES, NPD_BAND) SBRV3A.189
! REFERENCE SCALING TEMPERATURE SBRV3A.190
& , GAS_MIX_RATIO(NPD_PROFILE, 0: NPD_LAYER, NPD_SPECIES) SBRV3A.191
! GAS MASS MIXING RATIOS SBRV3A.192
& , GAS_FRAC_RESCALED(NPD_PROFILE, 0: NPD_LAYER, NPD_SPECIES) SBRV3A.193
! RESCALED GAS MASS FRACTIONS SBRV3A.194
& , DOPPLER_CORRECTION(NPD_SPECIES) SBRV3A.195
! DOPPLER BROADENING TERMS SBRV3A.196
! SBRV3A.197
! Spectral Region SBRV3A.198
INTEGER !, INTENT(IN) SBRV3A.199
& ISOLIR SBRV3A.200
! VISIBLE OR IR SBRV3A.201
! SBRV3A.202
! Solar Properties SBRV3A.203
REAL !, INTENT(IN) SBRV3A.204
& SEC_0(NPD_PROFILE) SBRV3A.205
! SECANT OF SOLAR ZENITH ANGLE SBRV3A.206
& , SOLAR_FLUX(NPD_PROFILE) SBRV3A.207
! INCIDENT SOLAR FLUX IN BAND SBRV3A.208
! SBRV3A.209
! Infra-red Properties SBRV3A.210
LOGICAL !, INTENT(IN) SBRV3A.211
& L_IR_SOURCE_QUAD SBRV3A.212
! USE A QUADRATIC SOURCE FUNCTION SBRV3A.213
REAL !, INTENT(IN) SBRV3A.214
& PLANCK_SOURCE_TOP(NPD_PROFILE) SBRV3A.215
! PLANCKIAN SOURCE AT TOP SBRV3A.216
& , PLANCK_SOURCE_BOTTOM(NPD_PROFILE) SBRV3A.217
! PLANCKIAN SOURCE AT BOTTOM SBRV3A.218
& , DIFF_PLANCK_BAND(NPD_PROFILE, NPD_LAYER) SBRV3A.219
! THERMAL SOURCE FUNCTION SBRV3A.220
& , DIFF_PLANCK_BAND_2(NPD_PROFILE, NPD_LAYER) SBRV3A.221
! 2x2ND DIFFERENCE OF PLANCKIAN IN BAND SBRV3A.222
! SBRV3A.223
! Surface Properties SBRV3A.224
REAL !, INTENT(IN) SBRV3A.225
& ALBEDO_SURFACE_DIFF(NPD_PROFILE) SBRV3A.226
! DIFFUSE SURFACE ALBEDO SBRV3A.227
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) SBRV3A.228
! DIRECT SURFACE ALBEDO SBRV3A.229
& , THERMAL_GROUND_BAND(NPD_PROFILE) SBRV3A.230
! THERMAL SOURCE FUNCTION AT GROUND SBRV3A.231
! SBRV3A.232
! Clear-sky Optical Properties SBRV3A.233
REAL !, INTENT(IN) SBRV3A.234
& K_GREY_TOT_FREE(NPD_PROFILE, NPD_LAYER) SBRV3A.235
! FREE ABSORPTIVE EXTINCTION SBRV3A.236
& , K_EXT_SCAT_FREE(NPD_PROFILE, NPD_LAYER) SBRV3A.237
! FREE SCATTERING EXTINCTION SBRV3A.238
& , ASYMMETRY_FREE(NPD_PROFILE, NPD_LAYER) SBRV3A.239
! CLEAR-SKY ASYMMETRY SBRV3A.240
& , FORWARD_SCATTER_FREE(NPD_PROFILE, NPD_LAYER) SBRV3A.241
! FREE FORWARD SCATTERING SBRV3A.242
! SBRV3A.243
! Cloudy properties SBRV3A.244
LOGICAL !, INTENT(IN) SBRV3A.245
& L_CLOUD SBRV3A.246
! CLOUD ENABLED SBRV3A.247
INTEGER !, INTENT(IN) SBRV3A.248
& I_CLOUD SBRV3A.249
! CLOUD SCHEME USED SBRV3A.250
! SBRV3A.251
! Cloud Geometry SBRV3A.252
INTEGER !, INTENT(IN) SBRV3A.253
& N_CLOUD_TOP SBRV3A.254
! TOPMOST CLOUDY LAYER SBRV3A.255
& , N_CLOUD_TYPE SBRV3A.256
! NUMBER OF TYPES OF CLOUD SBRV3A.257
& , N_FREE_PROFILE(NPD_LAYER) SBRV3A.258
! NUMBER OF FREE PROFILES SBRV3A.259
& , I_FREE_PROFILE(NPD_PROFILE, NPD_LAYER) SBRV3A.260
! INDICES OF FREE PROFILES SBRV3A.261
& , N_CLOUD_PROFILE(NPD_LAYER) SBRV3A.262
! NUMBER OF CLOUDY PROFILES SBRV3A.263
& , I_CLOUD_PROFILE(NPD_PROFILE, NPD_LAYER) SBRV3A.264
! INDICES OF CLOUDY PROFILES SBRV3A.265
& , N_COLUMN(NPD_PROFILE) SBRV3A.266
! NUMBER OF COLUMNS REQUIRED SBRV3A.267
& , I_REGION_CLOUD(NPD_CLOUD_TYPE) ADB1F402.669
! REGIONS IN WHICH TYPES OF CLOUDS FALL ADB1F402.670
LOGICAL !, INTENT(IN) SBRV3A.268
& L_COLUMN(NPD_PROFILE, NPD_LAYER, NPD_COLUMN) SBRV3A.269
! FLAGS FOR CONTENT OF COLUMNS SBRV3A.270
REAL !, INTENT(IN) SBRV3A.271
& W_CLOUD(NPD_PROFILE, NPD_LAYER) SBRV3A.272
! CLOUDY FRACTION SBRV3A.273
& , FRAC_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SBRV3A.274
! FRACTIONS OF TYPES OF CLOUDS SBRV3A.275
& , W_FREE(NPD_PROFILE, NPD_LAYER) SBRV3A.276
! CLEAR-SKY FRACTION SBRV3A.277
& , CLOUD_OVERLAP(NPD_PROFILE, 0: NPD_LAYER, NPD_OVERLAP_COEFF) SBRV3A.278
! COEFFICIENTS FOR TRANSFER FOR ENERGY AT INTERFACES SBRV3A.279
& , AREA_COLUMN(NPD_PROFILE, NPD_COLUMN) SBRV3A.280
! AREAS OF COLUMNS SBRV3A.281
& , FRAC_REGION(NPD_PROFILE, NPD_LAYER, NPD_REGION) ADB1F402.671
! FRACTIONS OF TOTAL CLOUD OCCUPIED BY EACH REGION ADB1F402.672
! SBRV3A.282
! Cloudy Optical Properties SBRV3A.283
REAL !, INTENT(IN) SBRV3A.284
& K_GREY_TOT_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SBRV3A.285
! CLOUDY ABSORPTIVE EXTINCTION SBRV3A.286
& , K_EXT_SCAT_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SBRV3A.287
! CLOUDY SCATTERING EXTINCTION SBRV3A.288
& , ASYMMETRY_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SBRV3A.289
! CLOUDY ASYMMETRY SBRV3A.290
& , FORWARD_SCATTER_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SBRV3A.291
! CLOUDY FORWARD SCATTERING SBRV3A.292
! SBRV3A.293
! Flags for Clear-sky Calculations SBRV3A.294
LOGICAL !, INTENT(IN) SBRV3A.295
& L_CLEAR SBRV3A.296
! CALCULATE CLEAR-SKY PROPERTIES SBRV3A.297
INTEGER !, INTENT(IN) SBRV3A.298
& I_SOLVER_CLEAR SBRV3A.299
! CLEAR SOLVER USED SBRV3A.300
! SBRV3A.301
! Planckian Source Function SBRV3A.302
REAL !, INTENT(IN) SBRV3A.303
& PLANCK_SOURCE_BAND(NPD_PROFILE, 0: NPD_LAYER) SBRV3A.304
! PLANCKIAN SOURCE IN BAND SBRV3A.305
! SBRV3A.306
! Fluxes Calculated SBRV3A.307
REAL !, INTENT(OUT) SBRV3A.308
& FLUX_DIRECT_BAND(NPD_PROFILE, 0: NPD_LAYER) SBRV3A.309
! DIRECT FLUX IN BAND SBRV3A.310
& , FLUX_TOTAL_BAND(NPD_PROFILE, 2*NPD_LAYER+2) SBRV3A.311
! TOTAL FLUX IN BAND SBRV3A.312
! SBRV3A.313
! Clear-sky Fluxes Calculated SBRV3A.314
REAL !, INTENT(OUT) SBRV3A.315
& FLUX_DIRECT_CLEAR_BAND(NPD_PROFILE, 0: NPD_LAYER) SBRV3A.316
! CLEAR-SKY DIRECT FLUX IN BAND SBRV3A.317
& , FLUX_TOTAL_CLEAR_BAND(NPD_PROFILE, 2*NPD_LAYER+2) SBRV3A.318
! CLEAR-SKY TOTAL FLUX IN BAND SBRV3A.319
! SBRV3A.320
! SBRV3A.321
! SBRV3A.322
! LOCAL VARIABLES. SBRV3A.323
INTEGER SBRV3A.324
& J SBRV3A.325
! LOOP VARIABLE SBRV3A.326
& , K SBRV3A.327
! LOOP VARIABLE SBRV3A.328
& , L SBRV3A.329
! LOOP VARIABLE SBRV3A.330
INTEGER SBRV3A.331
& I_GAS_BAND SBRV3A.332
! INDEX OF ACTIVE GAS SBRV3A.333
& , I_GAS_POINTER(NPD_SPECIES) SBRV3A.334
! POINTER ARRAY FOR MONOCHROMATIC ESFTs SBRV3A.335
& , I_ESFT_POINTER(NPD_SPECIES) SBRV3A.336
! POINTER TO ESFT FOR GAS SBRV3A.337
& , I_CHANGE SBRV3A.338
! POSITION OF ESFT TERM TO BE ALTERED SBRV3A.339
& , INDEX_CHANGE SBRV3A.340
! INDEX OF TERM TO BE ALTERED SBRV3A.341
& , INDEX_LAST SBRV3A.342
! INDEX OF LAST GAS IN BAND SBRV3A.343
& , IEX SBRV3A.344
! INDEX OF ESFT TERM SBRV3A.345
REAL SBRV3A.346
& K_ESFT_MONO(NPD_SPECIES) SBRV3A.347
! ESFT MONOCHROMATIC EXPONENTS SBRV3A.348
& , K_GAS_ABS(NPD_PROFILE, NPD_LAYER) SBRV3A.349
! GASEOUS ABSORPTION SBRV3A.350
& , SOURCE_GROUND(NPD_PROFILE) SBRV3A.351
! GROUND SOURCE FUNCTION SBRV3A.352
& , FLUX_INC_DIRECT(NPD_PROFILE) SBRV3A.353
! INCIDENT DIRECT FLUX SBRV3A.354
& , FLUX_INC_DOWN(NPD_PROFILE) SBRV3A.355
! INCIDENT DOWNWARD FLUX SBRV3A.356
& , PRODUCT_WEIGHT SBRV3A.357
! PRODUCT OF ESFT WEIGHTS SBRV3A.358
& , DUMMY_KE(NPD_PROFILE, NPD_LAYER) SBRV3A.359
! DUMMY ARRAY (NOT USED) SBRV3A.360
REAL SBRV3A.361
& FLUX_DIRECT_PART(NPD_PROFILE, 0: NPD_LAYER) SBRV3A.362
! PARTIAL DIRECT FLUX SBRV3A.363
& , FLUX_TOTAL_PART(NPD_PROFILE, 2*NPD_LAYER+2) SBRV3A.364
! PARTIAL TOTAL FLUX SBRV3A.365
& , FLUX_DIRECT_CLEAR_PART(NPD_PROFILE, 0: NPD_LAYER) SBRV3A.366
! PARTIAL CLEAR-SKY DIRECT FLUX SBRV3A.367
& , FLUX_TOTAL_CLEAR_PART(NPD_PROFILE, 2*NPD_LAYER+2) SBRV3A.368
! PARTIAL CLEAR-SKY TOTAL FLUX SBRV3A.369
! SBRV3A.370
! SUBROUTINES CALLED: SBRV3A.371
EXTERNAL SBRV3A.372
& SCALE_ABSORB, GAS_OPTICAL_PROPERTIES SBRV3A.373
& , MONOCHROMATIC_FLUX, AUGMENT_FLUX SBRV3A.374
! SBRV3A.375
! SBRV3A.376
! SBRV3A.377
! SET THE NUMBER OF ACTIVE GASES AND INITIALIZE THE POINTERS. SBRV3A.378
DO K=1, N_GAS SBRV3A.379
I_GAS_POINTER(K)=INDEX_ABSORB(K, I_BAND) SBRV3A.380
I_ESFT_POINTER(INDEX_ABSORB(K, I_BAND))=1 SBRV3A.381
ENDDO SBRV3A.382
INDEX_LAST=INDEX_ABSORB(N_GAS, I_BAND) SBRV3A.383
! SBRV3A.384
! PERFORM THE INITIAL RESCALING OF THE GASES OTHER THAN THE LAST. SBRV3A.385
! NOTE: WE RESCALE AMOUNTS AS REQUIRED. IT WOULD BE MORE SBRV3A.386
! EFFICIENT TO SAVE THE RESCALED AMOUNTS, BUT THE STORAGE SBRV3A.387
! NEEDED WOULD BECOME EXCESSIVE FOR A MULTICOLUMN CODE. IN A SBRV3A.388
! SINGLE CODE THE OVERHEAD IS LESS SIGNIFICANT. SBRV3A.389
DO K=1, N_GAS-1 SBRV3A.390
I_GAS_BAND=I_GAS_POINTER(K) SBRV3A.391
! INITIALIZE THE MONOCHROMATIC ABSORPTION COEFFICIENTS. SBRV3A.392
K_ESFT_MONO(I_GAS_BAND) SBRV3A.393
& =K_ESFT(1, I_BAND, I_GAS_BAND) SBRV3A.394
IF (I_SCALE_ESFT(I_BAND, I_GAS_BAND).EQ.IP_SCALE_TERM) THEN SBRV3A.395
CALL SCALE_ABSORB(IERR, N_PROFILE, N_LAYER SBRV3A.396
& , GAS_MIX_RATIO(1, 0, I_GAS_BAND), P, T SBRV3A.397
& , L_LAYER, I_TOP SBRV3A.398
& , GAS_FRAC_RESCALED(1, 0, I_GAS_BAND) SBRV3A.399
& , I_SCALE_FNC(I_BAND, I_GAS_BAND) SBRV3A.400
& , P_REFERENCE(I_GAS_BAND, I_BAND) SBRV3A.401
& , T_REFERENCE(I_GAS_BAND, I_BAND) SBRV3A.402
& , SCALE_VECTOR(1, 1, I_BAND, I_GAS_BAND) SBRV3A.403
& , L_DOPPLER(I_GAS_BAND), DOPPLER_CORRECTION(I_GAS_BAND) SBRV3A.404
& , NPD_PROFILE, NPD_LAYER, NPD_SCALE_FNC SBRV3A.405
& , NPD_SCALE_VARIABLE SBRV3A.406
& ) SBRV3A.407
IF (IERR.NE.I_NORMAL) RETURN SBRV3A.408
ENDIF SBRV3A.409
ENDDO SBRV3A.410
! SBRV3A.411
! LOOP THROUGH THE TERMS FOR THE FIRST ABSORBER. SBRV3A.412
2000 I_ESFT_POINTER(INDEX_LAST)=0 SBRV3A.413
DO K=1, I_BAND_ESFT(I_BAND, INDEX_LAST) SBRV3A.414
I_ESFT_POINTER(INDEX_LAST) SBRV3A.415
& =I_ESFT_POINTER(INDEX_LAST)+1 SBRV3A.416
! SBRV3A.417
! SET THE ESFT COEFFICIENT AND PERFORM RESCALING FOR THE SBRV3A.418
! LAST GAS. SBRV3A.419
IEX=I_ESFT_POINTER(INDEX_LAST) SBRV3A.420
K_ESFT_MONO(INDEX_LAST) SBRV3A.421
& =K_ESFT(IEX, I_BAND, INDEX_LAST) SBRV3A.422
IF (I_SCALE_ESFT(I_BAND, INDEX_LAST).EQ.IP_SCALE_TERM) THEN SBRV3A.423
CALL SCALE_ABSORB(IERR, N_PROFILE, N_LAYER SBRV3A.424
& , GAS_MIX_RATIO(1, 0, INDEX_LAST), P, T SBRV3A.425
& , L_LAYER, I_TOP SBRV3A.426
& , GAS_FRAC_RESCALED(1, 0, INDEX_LAST) SBRV3A.427
& , I_SCALE_FNC(I_BAND, INDEX_LAST) SBRV3A.428
& , P_REFERENCE(INDEX_LAST, I_BAND) SBRV3A.429
& , T_REFERENCE(INDEX_LAST, I_BAND) SBRV3A.430
& , SCALE_VECTOR(1, IEX, I_BAND, INDEX_LAST) SBRV3A.431
& , L_DOPPLER(INDEX_LAST) SBRV3A.432
& , DOPPLER_CORRECTION(INDEX_LAST) SBRV3A.433
& , NPD_PROFILE, NPD_LAYER, NPD_SCALE_FNC SBRV3A.434
& , NPD_SCALE_VARIABLE SBRV3A.435
& ) SBRV3A.436
IF (IERR.NE.I_NORMAL) RETURN SBRV3A.437
ENDIF SBRV3A.438
! SBRV3A.439
! SET THE APPROPRIATE SOURCE TERMS FOR THE TWO-STREAM SBRV3A.440
! EQUATIONS. SBRV3A.441
! THE PRODUCT OF THE ESFT WEIGHGTS CAN BE PRECALCULATED SBRV3A.442
! FOR SPEED. SBRV3A.443
PRODUCT_WEIGHT=1.0E+00 SBRV3A.444
DO J=1, N_GAS SBRV3A.445
I_GAS_BAND=I_GAS_POINTER(J) SBRV3A.446
IEX=I_ESFT_POINTER(I_GAS_BAND) SBRV3A.447
PRODUCT_WEIGHT=PRODUCT_WEIGHT SBRV3A.448
& *W_ESFT(IEX, I_BAND, I_GAS_BAND) SBRV3A.449
ENDDO SBRV3A.450
! SBRV3A.451
IF (ISOLIR.EQ.IP_SOLAR) THEN SBRV3A.452
! VISIBLE REGION. SBRV3A.453
DO L=1, N_PROFILE SBRV3A.454
SOURCE_GROUND(L)=0.0E+00 SBRV3A.455
FLUX_INC_DOWN(L)=SOLAR_FLUX(L) SBRV3A.456
FLUX_INC_DIRECT(L)=SOLAR_FLUX(L) SBRV3A.457
ENDDO SBRV3A.458
ELSEIF (ISOLIR.EQ.IP_INFRA_RED) THEN SBRV3A.459
! INFRA-RED REGION. SBRV3A.460
DO L=1, N_PROFILE SBRV3A.461
FLUX_INC_DIRECT(L)=0.0E+00 SBRV3A.462
FLUX_DIRECT_PART(L, N_LAYER)=0.0E+00 ADB1F401.910
FLUX_INC_DOWN(L)=-PLANCK_SOURCE_TOP(L) SBRV3A.463
SOURCE_GROUND(L)=THERMAL_GROUND_BAND(L) SBRV3A.464
& -(1.-ALBEDO_SURFACE_DIFF(L)) SBRV3A.465
& *PLANCK_SOURCE_BOTTOM(L) SBRV3A.466
ENDDO SBRV3A.467
IF (L_CLEAR) THEN ADB1F401.911
DO L=1, N_PROFILE ADB1F401.912
FLUX_DIRECT_CLEAR_PART(L, N_LAYER)=0.0E+00 ADB1F401.913
ENDDO ADB1F401.914
ENDIF ADB1F401.915
ENDIF SBRV3A.468
! SBRV3A.469
CALL GAS_OPTICAL_PROPERTIES(N_PROFILE, N_LAYER SBRV3A.470
& , N_GAS, I_GAS_POINTER, K_ESFT_MONO SBRV3A.471
& , GAS_FRAC_RESCALED SBRV3A.472
& , K_GAS_ABS SBRV3A.473
& , NPD_PROFILE, NPD_LAYER, NPD_SPECIES SBRV3A.474
& ) SBRV3A.475
! SBRV3A.476
! SBRV3A.477
CALL MONOCHROMATIC_FLUX(IERR SBRV3A.478
! Atmospheric Properties SBRV3A.479
& , N_PROFILE, N_LAYER, D_MASS SBRV3A.480
! Angular Integration SBRV3A.481
& , I_ANGULAR_INTEGRATION, I_2STREAM, L_2_STREAM_CORRECT SBRV3A.482
& , L_RESCALE, N_ORDER_GAUSS SBRV3A.483
! Treatment of Scattering SBRV3A.484
& , I_SCATTER_METHOD_BAND SBRV3A.485
! Options for Solver SBRV3A.486
& , I_SOLVER, L_NET, N_AUGMENT ADB1F405.588
! Gaseous Propreties SBRV3A.488
& , K_GAS_ABS SBRV3A.489
! Options for Equivalent Extinction SBRV3A.490
& , .FALSE., DUMMY_KE SBRV3A.491
! Spectral Region SBRV3A.492
& , ISOLIR SBRV3A.493
! Infra-red Properties SBRV3A.494
& , DIFF_PLANCK_BAND SBRV3A.495
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_BAND_2 SBRV3A.496
! Conditions at TOA SBRV3A.497
& , SEC_0, FLUX_INC_DIRECT, FLUX_INC_DOWN SBRV3A.498
! Surface Properties SBRV3A.499
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR, SOURCE_GROUND SBRV3A.500
& , THERMAL_GROUND_BAND SBRV3A.501
! Clear-sky Optical Properties SBRV3A.502
& , K_GREY_TOT_FREE, K_EXT_SCAT_FREE SBRV3A.503
& , ASYMMETRY_FREE, FORWARD_SCATTER_FREE SBRV3A.504
! Cloudy Properties SBRV3A.505
& , L_CLOUD, I_CLOUD SBRV3A.506
! Cloud Geometry SBRV3A.507
& , N_CLOUD_TOP SBRV3A.508
& , N_CLOUD_TYPE, FRAC_CLOUD SBRV3A.509
& , I_REGION_CLOUD, FRAC_REGION ADB1F402.673
& , W_FREE, N_FREE_PROFILE, I_FREE_PROFILE SBRV3A.510
& , W_CLOUD, N_CLOUD_PROFILE, I_CLOUD_PROFILE SBRV3A.511
& , CLOUD_OVERLAP SBRV3A.512
& , N_COLUMN, L_COLUMN, AREA_COLUMN SBRV3A.513
! Cloudy Optical Properties SBRV3A.514
& , K_GREY_TOT_CLOUD, K_EXT_SCAT_CLOUD SBRV3A.515
& , ASYMMETRY_CLOUD, FORWARD_SCATTER_CLOUD SBRV3A.516
! Fluxes Calculated ADB1F401.916
& , FLUX_DIRECT_PART, FLUX_TOTAL_PART SBRV3A.518
! Flags for Clear-sky Calculations SBRV3A.519
& , L_CLEAR, I_SOLVER_CLEAR SBRV3A.520
! Clear-sky Fluxes Calculated SBRV3A.521
& , FLUX_DIRECT_CLEAR_PART, FLUX_TOTAL_CLEAR_PART SBRV3A.522
! Planckian Function SBRV3A.523
& , PLANCK_SOURCE_BAND SBRV3A.524
! Dimensions of Arrays SBRV3A.525
& , NPD_PROFILE, NPD_LAYER, NPD_COLUMN SBRV3A.526
& ) SBRV3A.527
IF (IERR.NE.I_NORMAL) RETURN SBRV3A.528
! SBRV3A.529
! INCREMENT THE FLUXES WITHIN THE BAND. SBRV3A.530
CALL AUGMENT_FLUX(N_PROFILE, N_LAYER, N_AUGMENT SBRV3A.531
& , ISOLIR, L_CLEAR SBRV3A.532
& , PRODUCT_WEIGHT SBRV3A.533
& , FLUX_DIRECT_BAND, FLUX_TOTAL_BAND SBRV3A.534
& , FLUX_DIRECT_PART, FLUX_TOTAL_PART SBRV3A.535
& , FLUX_DIRECT_CLEAR_BAND, FLUX_TOTAL_CLEAR_BAND SBRV3A.536
& , FLUX_DIRECT_CLEAR_PART, FLUX_TOTAL_CLEAR_PART SBRV3A.537
& , NPD_PROFILE, NPD_LAYER SBRV3A.538
& ) SBRV3A.539
ENDDO SBRV3A.540
! SBRV3A.541
IF (N_GAS.GT.1) THEN SBRV3A.542
! INCREMENT THE ESFT POINTERS FOR THE NEXT PASS THROUGH SBRV3A.543
! THE LOOP ABOVE. I_CHANGE IS THE ORDINAL OF THE GAS, SBRV3A.544
! THE POINTER OF WHICH IS TO BE CHANGED. SBRV3A.545
I_CHANGE=N_GAS-1 SBRV3A.546
2001 INDEX_CHANGE=INDEX_ABSORB(I_CHANGE, I_BAND) SBRV3A.547
IF (I_BAND_ESFT(I_BAND, INDEX_CHANGE) SBRV3A.548
& .GT.I_ESFT_POINTER(INDEX_CHANGE)) THEN SBRV3A.549
I_ESFT_POINTER(INDEX_CHANGE) SBRV3A.550
& =I_ESFT_POINTER(INDEX_CHANGE)+1 SBRV3A.551
! RESCALE THE AMOUNT OF THIS GAS AND ADVANCE THE SBRV3A.552
! ESFT TERM. SBRV3A.553
K_ESFT_MONO(INDEX_CHANGE) SBRV3A.554
& =K_ESFT(I_ESFT_POINTER(INDEX_CHANGE) SBRV3A.555
& , I_BAND, INDEX_CHANGE) SBRV3A.556
IF (I_SCALE_ESFT(I_BAND, INDEX_CHANGE).EQ.IP_SCALE_TERM) SBRV3A.557
& THEN SBRV3A.558
CALL SCALE_ABSORB(IERR, N_PROFILE, N_LAYER SBRV3A.559
& , GAS_MIX_RATIO(1, 0, INDEX_CHANGE), P, T SBRV3A.560
& , L_LAYER, I_TOP SBRV3A.561
& , GAS_FRAC_RESCALED(1, 0, INDEX_CHANGE) SBRV3A.562
& , I_SCALE_FNC(I_BAND, INDEX_CHANGE) SBRV3A.563
& , P_REFERENCE(INDEX_CHANGE, I_BAND) SBRV3A.564
& , T_REFERENCE(INDEX_CHANGE, I_BAND) SBRV3A.565
& , SCALE_VECTOR(1, I_ESFT_POINTER(INDEX_CHANGE) ADB1F401.917
& , I_BAND, INDEX_CHANGE) ADB1F401.918
& , L_DOPPLER(INDEX_CHANGE) SBRV3A.567
& , DOPPLER_CORRECTION(INDEX_CHANGE) SBRV3A.568
& , NPD_PROFILE, NPD_LAYER, NPD_SCALE_FNC SBRV3A.569
& , NPD_SCALE_VARIABLE SBRV3A.570
& ) SBRV3A.571
IF (IERR.NE.I_NORMAL) RETURN SBRV3A.572
ENDIF SBRV3A.573
GOTO 2000 SBRV3A.574
ELSE IF (I_CHANGE.GT.1) THEN SBRV3A.575
! ALL TERMS FOR THIS ABSORBER HAVE BEEN DONE: SBRV3A.576
! RESET ITS POINTER TO 1 AND MOVE TO THE NEXT ABSORBER. SBRV3A.577
I_ESFT_POINTER(INDEX_CHANGE)=1 SBRV3A.578
K_ESFT_MONO(INDEX_CHANGE)=K_ESFT(1, I_BAND, INDEX_CHANGE) SBRV3A.579
I_CHANGE=I_CHANGE-1 SBRV3A.580
GOTO 2001 SBRV3A.581
ENDIF SBRV3A.582
ENDIF SBRV3A.583
! ADB1F401.919
! SBRV3A.584
! SBRV3A.585
RETURN SBRV3A.586
END SBRV3A.587
*ENDIF DEF,A01_3A,OR,DEF,A02_3A SBRV3A.588
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.82