SUBROUTINE SOLVE_BAND_ONE_GAS(IERR 2,4SB1G3A.20
! Atmospheric Column SB1G3A.21
& , N_PROFILE, N_LAYER, L_LAYER, I_TOP, P, T, D_MASS SB1G3A.22
! Angular Integration SB1G3A.23
& , I_ANGULAR_INTEGRATION, I_2STREAM, L_2_STREAM_CORRECT SB1G3A.24
& , L_RESCALE, N_ORDER_GAUSS SB1G3A.25
! Treatment of Scattering SB1G3A.26
& , I_SCATTER_METHOD_BAND SB1G3A.27
! Options for Solver SB1G3A.28
& , I_SOLVER, L_NET, N_AUGMENT ADB1F405.566
! Gaseous Properties SB1G3A.30
& , I_BAND, I_GAS SB1G3A.31
& , I_BAND_ESFT, I_SCALE_ESFT, I_SCALE_FNC SB1G3A.32
& , K_ESFT, W_ESFT, SCALE_VECTOR SB1G3A.33
& , P_REFERENCE, T_REFERENCE SB1G3A.34
& , GAS_MIX_RATIO, GAS_FRAC_RESCALED SB1G3A.35
& , L_DOPPLER, DOPPLER_CORRECTION SB1G3A.36
! Spectral Region SB1G3A.37
& , ISOLIR SB1G3A.38
! Solar Properties SB1G3A.39
& , SEC_0, SOLAR_FLUX SB1G3A.40
! Infra-red Properties SB1G3A.41
& , PLANCK_SOURCE_TOP, PLANCK_SOURCE_BOTTOM SB1G3A.42
& , DIFF_PLANCK_BAND SB1G3A.43
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_BAND_2 SB1G3A.44
! Surface Properties SB1G3A.45
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR, THERMAL_GROUND_BAND SB1G3A.46
! Clear-sky Optical Properties SB1G3A.47
& , K_GREY_TOT_FREE, K_EXT_SCAT_FREE, ASYMMETRY_FREE SB1G3A.48
& , FORWARD_SCATTER_FREE SB1G3A.49
! Cloudy Properties SB1G3A.50
& , L_CLOUD, I_CLOUD SB1G3A.51
! Cloud Geometry SB1G3A.52
& , N_CLOUD_TOP SB1G3A.53
& , N_CLOUD_TYPE, FRAC_CLOUD SB1G3A.54
& , I_REGION_CLOUD, FRAC_REGION ADB1F402.625
& , W_FREE, N_FREE_PROFILE, I_FREE_PROFILE SB1G3A.55
& , W_CLOUD, N_CLOUD_PROFILE, I_CLOUD_PROFILE SB1G3A.56
& , CLOUD_OVERLAP SB1G3A.57
& , N_COLUMN, L_COLUMN, AREA_COLUMN SB1G3A.58
! Cloudy Optical Properties SB1G3A.59
& , K_GREY_TOT_CLOUD, K_EXT_SCAT_CLOUD SB1G3A.60
& , ASYMMETRY_CLOUD, FORWARD_SCATTER_CLOUD SB1G3A.61
! Calculated Fluxes SB1G3A.62
& , FLUX_DIRECT_BAND, FLUX_TOTAL_BAND SB1G3A.63
! Flags for Clear-sky Fluxes SB1G3A.64
& , L_CLEAR, I_SOLVER_CLEAR SB1G3A.65
! Clear-sky Fluxes SB1G3A.66
& , FLUX_DIRECT_CLEAR_BAND, FLUX_TOTAL_CLEAR_BAND SB1G3A.67
! Planckian Function SB1G3A.68
& , PLANCK_SOURCE_BAND SB1G3A.69
! Dimensions of Arrays SB1G3A.70
& , NPD_PROFILE, NPD_LAYER, NPD_COLUMN SB1G3A.71
& , NPD_BAND, NPD_SPECIES SB1G3A.72
& , NPD_ESFT_TERM, NPD_SCALE_VARIABLE, NPD_SCALE_FNC SB1G3A.73
& ) SB1G3A.74
! SB1G3A.75
! SB1G3A.76
! SB1G3A.77
IMPLICIT NONE SB1G3A.78
! SB1G3A.79
! SB1G3A.80
! SIZES OF DUMMY ARRAYS. SB1G3A.81
INTEGER !, INTENT(IN) SB1G3A.82
& NPD_PROFILE SB1G3A.83
! MAXIMUM NUMBER OF PROFILES SB1G3A.84
& , NPD_LAYER SB1G3A.85
! MAXIMUM NUMBER OF LAYERS SB1G3A.86
& , NPD_COLUMN SB1G3A.87
! NUMBER OF COLUMNS PER POINT SB1G3A.88
& , NPD_BAND SB1G3A.89
! MAXIMUM NUMBER OF BANDS SB1G3A.90
& , NPD_SPECIES SB1G3A.91
! MAXIMUM NUMBER OF SPECIES SB1G3A.92
& , NPD_ESFT_TERM SB1G3A.93
! MAXIMUM NUMBER OF ESFT VARIABLES SB1G3A.94
& , NPD_SCALE_VARIABLE SB1G3A.95
! MAXIMUM NUMBER OF SCALING VARIABLES SB1G3A.96
& , NPD_SCALE_FNC SB1G3A.97
! MAXIMUM NUMBER OF SCALING FUNCTIONS SB1G3A.98
! SB1G3A.99
! INCLUDE COMDECKS. SB1G3A.100
*CALL DIMFIX3A 
SB1G3A.101
*CALL ESFTSC3A SB1G3A.102
*CALL SPCRG3A SB1G3A.103
*CALL ERROR3A SB1G3A.104
! SB1G3A.105
! SB1G3A.106
! SB1G3A.107
! DUMMY ARGUMENTS. SB1G3A.108
INTEGER !, INTENT(OUT) SB1G3A.109
& IERR SB1G3A.110
! ERROR FLAG SB1G3A.111
! SB1G3A.112
! Atmospheric Column SB1G3A.113
INTEGER !, INTENT(IN) SB1G3A.114
& N_PROFILE SB1G3A.115
! NUMBER OF PROFILES SB1G3A.116
& , N_LAYER SB1G3A.117
! NUMBER OF LAYERS SB1G3A.118
& , I_TOP SB1G3A.119
! TOP OF VERTICAL GRID SB1G3A.120
LOGICAL !, INTENT(IN) SB1G3A.121
& L_LAYER SB1G3A.122
! PROPERTIES GIVEN IN LAYERS SB1G3A.123
REAL !, INTENT(IN) SB1G3A.124
& P(NPD_PROFILE, 0: NPD_LAYER) SB1G3A.125
! PRESSURE SB1G3A.126
& , T(NPD_PROFILE, 0: NPD_LAYER) SB1G3A.127
! TEMPERATURE SB1G3A.128
& , D_MASS(NPD_PROFILE, NPD_LAYER) SB1G3A.129
! MASS THICKNESS OF EACH LAYER SB1G3A.130
! SB1G3A.131
! Angular Integration SB1G3A.132
INTEGER !, INTENT(IN) SB1G3A.133
& I_ANGULAR_INTEGRATION SB1G3A.134
! ANGULAR INTEGRATION SCHEME SB1G3A.135
& , I_2STREAM SB1G3A.136
! TWO-STREAM SCHEME SB1G3A.137
& , N_ORDER_GAUSS SB1G3A.138
! ORDER OF GAUSSIAN INTEGRATION SB1G3A.139
LOGICAL !, INTENT(IN) SB1G3A.140
& L_2_STREAM_CORRECT SB1G3A.141
! USE AN EDGE CORRECTION SB1G3A.142
& , L_RESCALE SB1G3A.143
! RESCALE OPTICAL PROPERTIES SB1G3A.144
! SB1G3A.145
! Treatment of Scattering SB1G3A.146
INTEGER !, INTENT(IN) SB1G3A.147
& I_SCATTER_METHOD_BAND SB1G3A.148
! METHOD OF TREATING SCATTERING SB1G3A.149
! SB1G3A.150
! Options for Solver SB1G3A.151
INTEGER !, INTENT(IN) SB1G3A.152
& I_SOLVER SB1G3A.153
! SOLVER USED SB1G3A.154
& , N_AUGMENT SB1G3A.157
! LENGTH OF LONG FLUX VECTOR SB1G3A.158
LOGICAL !, INTENT(IN) SB1G3A.159
& L_NET SB1G3A.160
! SOLVE FOR NET FLUXES SB1G3A.161
! SB1G3A.162
! Gaseous Properties SB1G3A.163
INTEGER !, INTENT(IN) SB1G3A.164
& I_BAND SB1G3A.165
! BAND BEING CONSIDERED SB1G3A.166
& , I_GAS SB1G3A.167
! GAS BEING CONSIDERED SB1G3A.168
& , I_BAND_ESFT(NPD_BAND, NPD_SPECIES) SB1G3A.169
! NUMBER OF TERMS IN BAND SB1G3A.170
& , I_SCALE_ESFT(NPD_BAND, NPD_SPECIES) SB1G3A.171
! TYPE OF ESFT SCALING SB1G3A.172
& , I_SCALE_FNC(NPD_BAND, NPD_SPECIES) SB1G3A.173
! TYPE OF SCALING FUNCTION SB1G3A.174
LOGICAL !, INTENT(IN) SB1G3A.175
& L_DOPPLER(NPD_SPECIES) SB1G3A.176
! DOPPLER BROADENING INCLUDED SB1G3A.177
REAL !, INTENT(IN) SB1G3A.178
& K_ESFT(NPD_ESFT_TERM, NPD_BAND, NPD_SPECIES) SB1G3A.179
! EXPONENTIAL ESFT TERMS SB1G3A.180
& , W_ESFT(NPD_ESFT_TERM, NPD_BAND, NPD_SPECIES) SB1G3A.181
! WEIGHTS FOR ESFT SB1G3A.182
& , SCALE_VECTOR(NPD_SCALE_VARIABLE, NPD_ESFT_TERM, NPD_BAND SB1G3A.183
& , NPD_SPECIES) SB1G3A.184
! ABSORBER SCALING PARAMETERS SB1G3A.185
& , P_REFERENCE(NPD_SPECIES, NPD_BAND) SB1G3A.186
! REFERENCE SCALING PRESSURE SB1G3A.187
& , T_REFERENCE(NPD_SPECIES, NPD_BAND) SB1G3A.188
! REFERENCE SCALING TEMPERATURE SB1G3A.189
& , GAS_MIX_RATIO(NPD_PROFILE, 0: NPD_LAYER, NPD_SPECIES) SB1G3A.190
! GAS MASS MIXING RATIOS SB1G3A.191
& , GAS_FRAC_RESCALED(NPD_PROFILE, 0: NPD_LAYER, NPD_SPECIES) SB1G3A.192
! RESCALED GAS MASS FRACTIONS SB1G3A.193
& , DOPPLER_CORRECTION(NPD_SPECIES) SB1G3A.194
! DOPPLER BROADENING TERMS SB1G3A.195
! SB1G3A.196
! Spectral Region SB1G3A.197
INTEGER !, INTENT(IN) SB1G3A.198
& ISOLIR SB1G3A.199
! VISIBLE OR IR SB1G3A.200
! SB1G3A.201
! Solar Properties SB1G3A.202
REAL !, INTENT(IN) SB1G3A.203
& SEC_0(NPD_PROFILE) SB1G3A.204
! SECANT OF SOLAR ZENITH ANGLE SB1G3A.205
& , SOLAR_FLUX(NPD_PROFILE) SB1G3A.206
! INCIDENT SOLAR FLUX IN BAND SB1G3A.207
! SB1G3A.208
! Infra-red Properties SB1G3A.209
LOGICAL !, INTENT(IN) SB1G3A.210
& L_IR_SOURCE_QUAD SB1G3A.211
! USE A QUADRATIC SOURCE FUNCTION SB1G3A.212
REAL !, INTENT(IN) SB1G3A.213
& PLANCK_SOURCE_TOP(NPD_PROFILE) SB1G3A.214
! PLANCKIAN SOURCE AT TOP SB1G3A.215
& , PLANCK_SOURCE_BOTTOM(NPD_PROFILE) SB1G3A.216
! PLANCKIAN SOURCE AT BOTTOM SB1G3A.217
& , DIFF_PLANCK_BAND(NPD_PROFILE, NPD_LAYER) SB1G3A.218
! THERMAL SOURCE FUNCTION SB1G3A.219
& , DIFF_PLANCK_BAND_2(NPD_PROFILE, NPD_LAYER) SB1G3A.220
! TWICE SECOND DIFFERENCE OF PLANCKIAN IN BAND SB1G3A.221
! SB1G3A.222
! Surface Properties SB1G3A.223
REAL !, INTENT(IN) SB1G3A.224
& ALBEDO_SURFACE_DIFF(NPD_PROFILE) SB1G3A.225
! DIFFUSE SURFACE ALBEDO SB1G3A.226
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) SB1G3A.227
! DIRECT SURFACE ALBEDO SB1G3A.228
& , THERMAL_GROUND_BAND(NPD_PROFILE) SB1G3A.229
! THERMAL SOURCE FUNCTION AT GROUND SB1G3A.230
! SB1G3A.231
! Clear-sky optical Properties SB1G3A.232
REAL !, INTENT(IN) SB1G3A.233
& K_GREY_TOT_FREE(NPD_PROFILE, NPD_LAYER) SB1G3A.234
! FREE ABSORPTIVE EXTINCTION SB1G3A.235
& , K_EXT_SCAT_FREE(NPD_PROFILE, NPD_LAYER) SB1G3A.236
! FREE SCATTERING EXTINCTION SB1G3A.237
& , ASYMMETRY_FREE(NPD_PROFILE, NPD_LAYER) SB1G3A.238
! CLEAR-SKY ASYMMETRY SB1G3A.239
& , FORWARD_SCATTER_FREE(NPD_PROFILE, NPD_LAYER) SB1G3A.240
! FREE FORWARD SCATTERING SB1G3A.241
! SB1G3A.242
! Cloudy Properties SB1G3A.243
LOGICAL !, INTENT(IN) SB1G3A.244
& L_CLOUD SB1G3A.245
! CLOUDS REQUIRED SB1G3A.246
INTEGER !, INTENT(IN) SB1G3A.247
& I_CLOUD SB1G3A.248
! CLOUD SCHEME USED SB1G3A.249
! SB1G3A.250
! Cloud Geometry SB1G3A.251
INTEGER !, INTENT(IN) SB1G3A.252
& N_CLOUD_TOP SB1G3A.253
! TOP CLOUDY LAYER SB1G3A.254
& , N_CLOUD_TYPE SB1G3A.255
! NUMBER OF TYPES OF CLOUDS SB1G3A.256
& , N_FREE_PROFILE(NPD_LAYER) SB1G3A.257
! NUMBER OF FREE PROFILES SB1G3A.258
& , I_FREE_PROFILE(NPD_PROFILE, NPD_LAYER) SB1G3A.259
! INDICES OF FREE PROFILES SB1G3A.260
& , N_CLOUD_PROFILE(NPD_LAYER) SB1G3A.261
! NUMBER OF CLOUDY PROFILES SB1G3A.262
& , I_CLOUD_PROFILE(NPD_PROFILE, NPD_LAYER) SB1G3A.263
! INDICES OF CLOUDY PROFILES SB1G3A.264
& , N_COLUMN(NPD_PROFILE) SB1G3A.265
! NUMBER OF COLUMNS REQUIRED SB1G3A.266
& , I_REGION_CLOUD(NPD_CLOUD_TYPE) ADB1F402.626
! REGIONS IN WHICH TYPES OF CLOUDS FALL ADB1F402.627
LOGICAL !, INTENT(IN) SB1G3A.267
& L_COLUMN(NPD_PROFILE, NPD_LAYER, NPD_COLUMN) SB1G3A.268
! FLAGS FOR CONTENT OF COLUMNS SB1G3A.269
REAL !, INTENT(IN) SB1G3A.270
& W_FREE(NPD_PROFILE, NPD_LAYER) SB1G3A.271
! CLEAR-SKY FRACTION SB1G3A.272
& , W_CLOUD(NPD_PROFILE, NPD_LAYER) SB1G3A.273
! CLOUDY FRACTION SB1G3A.274
& , FRAC_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SB1G3A.275
! FRACTIONS OF TYPES OF CLOUDS SB1G3A.276
& , CLOUD_OVERLAP(NPD_PROFILE, 0: NPD_LAYER, NPD_OVERLAP_COEFF) SB1G3A.277
! COEFFICIENTS FOR TRANSFER FOR ENERGY AT INTERFACES SB1G3A.278
& , AREA_COLUMN(NPD_PROFILE, NPD_COLUMN) SB1G3A.279
! AREAS OF COLUMNS SB1G3A.280
& , FRAC_REGION(NPD_PROFILE, NPD_LAYER, NPD_REGION) ADB1F402.628
! FRACTIONS OF TOTAL CLOUD OCCUPIED BY EACH REGION ADB1F402.629
! SB1G3A.281
! Cloudy Optical Properties SB1G3A.282
REAL !, INTENT(IN) SB1G3A.283
& K_GREY_TOT_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SB1G3A.284
! CLOUDY ABSORPTIVE EXTINCTION SB1G3A.285
& , K_EXT_SCAT_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SB1G3A.286
! CLOUDY SCATTERING EXTINCTION SB1G3A.287
& , ASYMMETRY_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SB1G3A.288
! CLOUDY ASYMMETRY SB1G3A.289
& , FORWARD_SCATTER_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SB1G3A.290
! CLOUDY FORWARD SCATTERING SB1G3A.291
! SB1G3A.292
! Fluxes Calculated SB1G3A.293
REAL !, INTENT(OUT) SB1G3A.294
& FLUX_DIRECT_BAND(NPD_PROFILE, 0: NPD_LAYER) SB1G3A.295
! DIRECT FLUX SB1G3A.296
& , FLUX_TOTAL_BAND(NPD_PROFILE, 2*NPD_LAYER+2) SB1G3A.297
! TOTAL FLUX SB1G3A.298
! SB1G3A.299
! Flags for Clear-sky Calculations SB1G3A.300
LOGICAL !, INTENT(IN) SB1G3A.301
& L_CLEAR SB1G3A.302
! CALCULATE NET CLEAR-SKY PROPERTIES SB1G3A.303
INTEGER !, INTENT(IN) SB1G3A.304
& I_SOLVER_CLEAR SB1G3A.305
! CLEAR SOLVER USED SB1G3A.306
! SB1G3A.307
! Clear-sky Fluxes Calculated SB1G3A.308
REAL !, INTENT(OUT) SB1G3A.309
& FLUX_DIRECT_CLEAR_BAND(NPD_PROFILE, 0: NPD_LAYER) SB1G3A.310
! CLEAR-SKY DIRECT FLUX SB1G3A.311
& , FLUX_TOTAL_CLEAR_BAND(NPD_PROFILE, 2*NPD_LAYER+2) SB1G3A.312
! CLEAR-SKY TOTAL FLUX SB1G3A.313
! SB1G3A.314
! Planckian Function SB1G3A.315
REAL !, INTENT(IN) SB1G3A.316
& PLANCK_SOURCE_BAND(NPD_PROFILE, 0: NPD_LAYER) SB1G3A.317
! PLANCKIAN SOURCE IN BAND SB1G3A.318
! SB1G3A.319
! SB1G3A.320
! SB1G3A.321
! LOCAL VARIABLES. SB1G3A.322
INTEGER SB1G3A.323
& L SB1G3A.324
! LOOP VARIABLE SB1G3A.325
INTEGER SB1G3A.326
& I_GAS_POINTER(NPD_SPECIES) SB1G3A.327
! POINTER ARRAY FOR MONOCHROMATIC ESFTs SB1G3A.328
& , IEX SB1G3A.329
! INDEX OF ESFT TERM SB1G3A.330
REAL SB1G3A.331
& K_ESFT_MONO(NPD_SPECIES) SB1G3A.332
! ESFT MONOCHROMATIC EXPONENTS SB1G3A.333
& , K_GAS_ABS(NPD_PROFILE, NPD_LAYER) SB1G3A.334
! GASEOUS ABSORPTIVE EXTINCTION SB1G3A.335
& , SOURCE_GROUND(NPD_PROFILE) SB1G3A.336
! GROUND SOURCE FUNCTION SB1G3A.337
& , FLUX_INC_DIRECT(NPD_PROFILE) SB1G3A.338
! INCIDENT DIRECT FLUX SB1G3A.339
& , FLUX_INC_DOWN(NPD_PROFILE) SB1G3A.340
! INCIDENT DOWNWARD FLUX SB1G3A.341
& , DUMMY_KE(NPD_PROFILE, NPD_LAYER) SB1G3A.342
! DUMMY ARRAY (NOT USED) SB1G3A.343
REAL SB1G3A.344
& FLUX_DIRECT_PART(NPD_PROFILE, 0: NPD_LAYER) SB1G3A.345
! PARTIAL DIRECT FLUX SB1G3A.346
& , FLUX_TOTAL_PART(NPD_PROFILE, 2*NPD_LAYER+2) SB1G3A.347
! PARTIAL TOTAL FLUX SB1G3A.348
& , FLUX_DIRECT_CLEAR_PART(NPD_PROFILE, 0: NPD_LAYER) SB1G3A.349
! PARTIAL CLEAR-SKY DIRECT FLUX SB1G3A.350
& , FLUX_TOTAL_CLEAR_PART(NPD_PROFILE, 2*NPD_LAYER+2) SB1G3A.351
! PARTIAL CLEAR-SKY TOTAL FLUX SB1G3A.352
! SB1G3A.353
! SUBROUTINES CALLED: SB1G3A.354
EXTERNAL SB1G3A.355
& SCALE_ABSORB, GAS_OPTICAL_PROPERTIES SB1G3A.356
& , MONOCHROMATIC_FLUX, AUGMENT_FLUX SB1G3A.357
! SB1G3A.358
! SB1G3A.359
! SB1G3A.360
SB1G3A.361
! THE ESFT TERMS FOR THE FIRST GAS IN THE BAND ALONE ARE USED. SB1G3A.362
I_GAS_POINTER(1)=I_GAS SB1G3A.363
DO IEX=1, I_BAND_ESFT(I_BAND, I_GAS) SB1G3A.364
! SB1G3A.365
! RESCALE FOR EACH ESFT TERM IF THAT IS REQUIRED. SB1G3A.366
IF (I_SCALE_ESFT(I_BAND, I_GAS).EQ.IP_SCALE_TERM) THEN SB1G3A.367
CALL SCALE_ABSORB(IERR, N_PROFILE, N_LAYER SB1G3A.368
& , GAS_MIX_RATIO(1, 0, I_GAS), P, T SB1G3A.369
& , L_LAYER, I_TOP SB1G3A.370
& , GAS_FRAC_RESCALED(1, 0, I_GAS) SB1G3A.371
& , I_SCALE_FNC(I_BAND, I_GAS) SB1G3A.372
& , P_REFERENCE(I_GAS, I_BAND) SB1G3A.373
& , T_REFERENCE(I_GAS, I_BAND) SB1G3A.374
& , SCALE_VECTOR(1, IEX, I_BAND, I_GAS) SB1G3A.375
& , L_DOPPLER(I_GAS), DOPPLER_CORRECTION(I_GAS) SB1G3A.376
& , NPD_PROFILE, NPD_LAYER, NPD_SCALE_FNC SB1G3A.377
& , NPD_SCALE_VARIABLE SB1G3A.378
& ) SB1G3A.379
IF (IERR.NE.I_NORMAL) RETURN SB1G3A.380
ENDIF SB1G3A.381
! SB1G3A.382
! SET THE APPROPRIATE BOUNDARY TERMS FOR THE TOTAL SB1G3A.383
! UPWARD AND DOWNWARD FLUXES. SB1G3A.384
! SB1G3A.385
IF (ISOLIR.EQ.IP_SOLAR) THEN SB1G3A.386
! VISIBLE REGION. SB1G3A.387
DO L=1, N_PROFILE SB1G3A.388
SOURCE_GROUND(L)=0.0E+00 SB1G3A.389
FLUX_INC_DOWN(L)=SOLAR_FLUX(L) SB1G3A.390
FLUX_INC_DIRECT(L)=SOLAR_FLUX(L) SB1G3A.391
ENDDO SB1G3A.392
ELSEIF (ISOLIR.EQ.IP_INFRA_RED) THEN SB1G3A.393
! INFRA-RED REGION. SB1G3A.394
DO L=1, N_PROFILE SB1G3A.395
FLUX_INC_DIRECT(L)=0.0E+00 SB1G3A.396
FLUX_INC_DOWN(L)=-PLANCK_SOURCE_TOP(L) SB1G3A.397
SOURCE_GROUND(L)=THERMAL_GROUND_BAND(L) SB1G3A.398
& -(1.0E+00-ALBEDO_SURFACE_DIFF(L)) SB1G3A.399
& *PLANCK_SOURCE_BOTTOM(L) SB1G3A.400
ENDDO SB1G3A.401
ENDIF SB1G3A.402
! SB1G3A.403
! ASSIGN THE MONOCHROMATIC ABSORPTION COEFFICIENT. SB1G3A.404
K_ESFT_MONO(I_GAS)=K_ESFT(IEX, I_BAND, I_GAS) SB1G3A.405
! SB1G3A.406
CALL GAS_OPTICAL_PROPERTIES(N_PROFILE, N_LAYER SB1G3A.407
& , 1, I_GAS_POINTER, K_ESFT_MONO SB1G3A.408
& , GAS_FRAC_RESCALED SB1G3A.409
& , K_GAS_ABS SB1G3A.410
& , NPD_PROFILE, NPD_LAYER, NPD_SPECIES SB1G3A.411
& ) SB1G3A.412
! SB1G3A.413
! SB1G3A.414
CALL MONOCHROMATIC_FLUX(IERR SB1G3A.415
! Atmospheric Properties SB1G3A.416
& , N_PROFILE, N_LAYER, D_MASS SB1G3A.417
! Angular Integration SB1G3A.418
& , I_ANGULAR_INTEGRATION, I_2STREAM, L_2_STREAM_CORRECT SB1G3A.419
& , L_RESCALE, N_ORDER_GAUSS SB1G3A.420
! Treatment of Scattering SB1G3A.421
& , I_SCATTER_METHOD_BAND SB1G3A.422
! Options for Solver SB1G3A.423
& , I_SOLVER, L_NET, N_AUGMENT ADB1F405.567
! Gaseous Propreties SB1G3A.425
& , K_GAS_ABS SB1G3A.426
! Options for Equivalent Extinction SB1G3A.427
& , .FALSE., DUMMY_KE SB1G3A.428
! Spectral Region SB1G3A.429
& , ISOLIR SB1G3A.430
! Infra-red Properties SB1G3A.431
& , DIFF_PLANCK_BAND SB1G3A.432
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_BAND_2 SB1G3A.433
! Conditions at TOA SB1G3A.434
& , SEC_0, FLUX_INC_DIRECT, FLUX_INC_DOWN SB1G3A.435
! Surface Properties SB1G3A.436
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR, SOURCE_GROUND SB1G3A.437
& , THERMAL_GROUND_BAND SB1G3A.438
! Clear-sky Optical Properties SB1G3A.439
& , K_GREY_TOT_FREE, K_EXT_SCAT_FREE SB1G3A.440
& , ASYMMETRY_FREE, FORWARD_SCATTER_FREE SB1G3A.441
! Cloudy Properties SB1G3A.442
& , L_CLOUD, I_CLOUD SB1G3A.443
! Cloud Geometry SB1G3A.444
& , N_CLOUD_TOP SB1G3A.445
& , N_CLOUD_TYPE, FRAC_CLOUD SB1G3A.446
& , I_REGION_CLOUD, FRAC_REGION ADB1F402.630
& , W_FREE, N_FREE_PROFILE, I_FREE_PROFILE SB1G3A.447
& , W_CLOUD, N_CLOUD_PROFILE, I_CLOUD_PROFILE SB1G3A.448
& , CLOUD_OVERLAP SB1G3A.449
& , N_COLUMN, L_COLUMN, AREA_COLUMN SB1G3A.450
! Cloudy Optical Properties SB1G3A.451
& , K_GREY_TOT_CLOUD, K_EXT_SCAT_CLOUD SB1G3A.452
& , ASYMMETRY_CLOUD, FORWARD_SCATTER_CLOUD SB1G3A.453
! Flxues Calculated SB1G3A.454
& , FLUX_DIRECT_PART, FLUX_TOTAL_PART SB1G3A.455
! Flags for Clear-sky Calculations SB1G3A.456
& , L_CLEAR, I_SOLVER_CLEAR SB1G3A.457
! Clear-sky Fluxes Calculated SB1G3A.458
& , FLUX_DIRECT_CLEAR_PART, FLUX_TOTAL_CLEAR_PART SB1G3A.459
! Planckian Function SB1G3A.460
& , PLANCK_SOURCE_BAND SB1G3A.461
! Dimensions of Arrays SB1G3A.462
& , NPD_PROFILE, NPD_LAYER, NPD_COLUMN SB1G3A.463
& ) SB1G3A.464
IF (IERR.NE.I_NORMAL) RETURN SB1G3A.465
! SB1G3A.466
! INCREMENT THE FLUXES WITHIN THE BAND. SB1G3A.467
CALL AUGMENT_FLUX(N_PROFILE, N_LAYER, N_AUGMENT SB1G3A.468
& , ISOLIR, L_CLEAR SB1G3A.469
& , W_ESFT(IEX, I_BAND, I_GAS) SB1G3A.470
& , FLUX_DIRECT_BAND, FLUX_TOTAL_BAND SB1G3A.471
& , FLUX_DIRECT_PART, FLUX_TOTAL_PART SB1G3A.472
& , FLUX_DIRECT_CLEAR_BAND, FLUX_TOTAL_CLEAR_BAND SB1G3A.473
& , FLUX_DIRECT_CLEAR_PART, FLUX_TOTAL_CLEAR_PART SB1G3A.474
& , NPD_PROFILE, NPD_LAYER SB1G3A.475
& ) SB1G3A.476
ENDDO SB1G3A.477
! SB1G3A.478
! SB1G3A.479
RETURN SB1G3A.480
END SB1G3A.481
*ENDIF DEF,A01_3A,OR,DEF,A02_3A SB1G3A.482
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.74