*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.83
*IF DEF,A01_3A,OR,DEF,A02_3A SBWG3A.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13824
C GTS2F400.13825
C Use, duplication or disclosure of this code is subject to the GTS2F400.13826
C restrictions as set forth in the contract. GTS2F400.13827
C GTS2F400.13828
C Meteorological Office GTS2F400.13829
C London Road GTS2F400.13830
C BRACKNELL GTS2F400.13831
C Berkshire UK GTS2F400.13832
C RG12 2SZ GTS2F400.13833
C GTS2F400.13834
C If no contract has been raised with this copy of the code, the use, GTS2F400.13835
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13836
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13837
C Modelling at the above address. GTS2F400.13838
C ******************************COPYRIGHT****************************** GTS2F400.13839
C GTS2F400.13840
!+ Subroutine to calculate the fluxes within the band with no gases. SBWG3A.3
! SBWG3A.4
! Method: SBWG3A.5
! Gaseous extinction is set to 0 and a monochromatic SBWG3A.6
! calculation is performed. SBWG3A.7
! SBWG3A.8
! Current Owner of Code: J. M. Edwards SBWG3A.9
! SBWG3A.10
! History: SBWG3A.11
! Version Date Comment SBWG3A.12
! 4.0 27-07-95 Original Code SBWG3A.13
! (J. M. Edwards) SBWG3A.14
! 4.2 08-08-96 Code for vertically ADB1F402.674
! coherent convective ADB1F402.675
! cloud added. ADB1F402.676
! (J. M. Edwards) ADB1F402.677
! 4.5 18-05-98 Variable for obsolete ADB1F405.589
! solver removed. ADB1F405.590
! (J. M. Edwards) ADB1F405.591
! SBWG3A.15
! Description of Code: SBWG3A.16
! FORTRAN 77 with extensions listed in documentation. SBWG3A.17
! SBWG3A.18
!- --------------------------------------------------------------------- SBWG3A.19
SUBROUTINE SOLVE_BAND_WITHOUT_GAS(IERR 1,1SBWG3A.20
! Atmospheric Column SBWG3A.21
& , N_PROFILE, N_LAYER, D_MASS SBWG3A.22
! Angular Integration SBWG3A.23
& , I_ANGULAR_INTEGRATION, I_2STREAM, L_2_STREAM_CORRECT SBWG3A.24
& , L_RESCALE, N_ORDER_GAUSS SBWG3A.25
! Treatment of scattering SBWG3A.26
& , I_SCATTER_METHOD_BAND SBWG3A.27
! Options for solver SBWG3A.28
& , I_SOLVER, L_NET, N_AUGMENT ADB1F405.592
! Spectral region SBWG3A.30
& , ISOLIR SBWG3A.31
! Solar properties SBWG3A.32
& , SEC_0, SOLAR_FLUX SBWG3A.33
! Infra-red properties SBWG3A.34
& , PLANCK_SOURCE_TOP, PLANCK_SOURCE_BOTTOM SBWG3A.35
& , DIFF_PLANCK_BAND, L_IR_SOURCE_QUAD, DIFF_PLANCK_BAND_2 SBWG3A.36
! Surface properties SBWG3A.37
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR, THERMAL_GROUND_BAND SBWG3A.38
! Clear-sky optical properties SBWG3A.39
& , K_GREY_TOT_FREE, K_EXT_SCAT_FREE, ASYMMETRY_FREE SBWG3A.40
& , FORWARD_SCATTER_FREE SBWG3A.41
! Cloudy properties SBWG3A.42
& , L_CLOUD, I_CLOUD SBWG3A.43
! Cloud Geometry SBWG3A.44
& , N_CLOUD_TOP SBWG3A.45
& , N_CLOUD_TYPE, FRAC_CLOUD SBWG3A.46
& , I_REGION_CLOUD, FRAC_REGION ADB1F402.678
& , W_FREE, N_FREE_PROFILE, I_FREE_PROFILE SBWG3A.47
& , W_CLOUD, N_CLOUD_PROFILE, I_CLOUD_PROFILE SBWG3A.48
& , CLOUD_OVERLAP SBWG3A.49
& , N_COLUMN, L_COLUMN, AREA_COLUMN SBWG3A.50
! Cloudy optical properties SBWG3A.51
& , K_GREY_TOT_CLOUD, K_EXT_SCAT_CLOUD SBWG3A.52
& , ASYMMETRY_CLOUD, FORWARD_SCATTER_CLOUD SBWG3A.53
! Calculated Fluxes SBWG3A.54
& , FLUX_DIRECT_BAND, FLUX_TOTAL_BAND SBWG3A.55
! Flags For Clear-sky Fluxes SBWG3A.56
& , L_CLEAR, I_SOLVER_CLEAR SBWG3A.57
! Calculated Clear-sky Fluxes SBWG3A.58
& , FLUX_DIRECT_CLEAR_BAND, FLUX_TOTAL_CLEAR_BAND SBWG3A.59
! Planckian Function SBWG3A.60
& , PLANCK_SOURCE_BAND SBWG3A.61
! Dimensions of Arrays SBWG3A.62
& , NPD_PROFILE, NPD_LAYER, NPD_COLUMN SBWG3A.63
& ) SBWG3A.64
! SBWG3A.65
! SBWG3A.66
! SBWG3A.67
IMPLICIT NONE SBWG3A.68
! SBWG3A.69
! SBWG3A.70
! SIZES OF DUMMY ARRAYS. SBWG3A.71
INTEGER !, INTENT(IN) SBWG3A.72
& NPD_PROFILE SBWG3A.73
! MAXIMUM NUMBER OF PROFILES SBWG3A.74
& , NPD_LAYER SBWG3A.75
! MAXIMUM NUMBER OF LAYERS SBWG3A.76
& , NPD_COLUMN SBWG3A.77
! NUMBER OF COLUMNS PER POINT SBWG3A.78
! SBWG3A.79
! INCLUDE COMDECKS. SBWG3A.80
*CALL DIMFIX3A
SBWG3A.81
*CALL SPCRG3A
SBWG3A.82
! SBWG3A.83
! DUMMY ARGUMENTS. SBWG3A.84
INTEGER !, INTENT(OUT) SBWG3A.85
& IERR SBWG3A.86
! ERROR FLAG SBWG3A.87
! SBWG3A.88
! Atmospheric Column SBWG3A.89
INTEGER !, INTENT(IN) SBWG3A.90
& N_PROFILE SBWG3A.91
! NUMBER OF PROFILES SBWG3A.92
& , N_LAYER SBWG3A.93
! NUMBER OF LAYERS SBWG3A.94
REAL !, INTENT(IN) SBWG3A.95
& D_MASS(NPD_PROFILE, NPD_LAYER) SBWG3A.96
! MASS THICKNESS OF EACH LAYER SBWG3A.97
! SBWG3A.98
! Angular integration SBWG3A.99
INTEGER !, INTENT(IN) SBWG3A.100
& I_ANGULAR_INTEGRATION SBWG3A.101
! ANGULAR INTEGRATION SCHEME SBWG3A.102
& , I_2STREAM SBWG3A.103
! TWO-STREAM SCHEME SBWG3A.104
& , N_ORDER_GAUSS SBWG3A.105
! ORDER OF GAUSSIAN INTEGRATION SBWG3A.106
LOGICAL !, INTENT(IN) SBWG3A.107
& L_2_STREAM_CORRECT SBWG3A.108
! USE AN EDGE CORRECTION SBWG3A.109
& , L_RESCALE SBWG3A.110
! RESCALE OPTICAL PROPERTIES SBWG3A.111
! SBWG3A.112
! Treatment of Scattering SBWG3A.113
INTEGER !, INTENT(IN) SBWG3A.114
& I_SCATTER_METHOD_BAND SBWG3A.115
! METHOD OF TREATING SCATTERING SBWG3A.116
! SBWG3A.117
! Options for solver SBWG3A.118
INTEGER !, INTENT(IN) SBWG3A.119
& I_SOLVER SBWG3A.120
! SOLVER USED SBWG3A.121
& , N_AUGMENT SBWG3A.124
! LENGTH OF LONG FLUX VECTOR SBWG3A.125
LOGICAL !, INTENT(IN) SBWG3A.126
& L_NET SBWG3A.127
! SOLVE FOR NET FLUXES SBWG3A.128
! SBWG3A.129
! Spectral Region SBWG3A.130
INTEGER !, INTENT(IN) SBWG3A.131
& ISOLIR SBWG3A.132
! VISIBLE OR IR SBWG3A.133
! SBWG3A.134
! Solar Properties SBWG3A.135
REAL !, INTENT(IN) SBWG3A.136
& SEC_0(NPD_PROFILE) SBWG3A.137
! SECANT OF SOLAR ZENITH ANGLE SBWG3A.138
& , SOLAR_FLUX(NPD_PROFILE) SBWG3A.139
! INCIDENT SOLAR FLUX SBWG3A.140
! SBWG3A.141
! Infra-red Properties SBWG3A.142
REAL !, INTENT(IN) SBWG3A.143
& PLANCK_SOURCE_TOP(NPD_PROFILE) SBWG3A.144
! PLANCK FUNCTION AT BOTTOM OF COLUMN SBWG3A.145
& , PLANCK_SOURCE_BOTTOM(NPD_PROFILE) SBWG3A.146
! PLANCK FUNCTION AT BOTTOM OF COLUMN SBWG3A.147
& , DIFF_PLANCK_BAND(NPD_PROFILE, NPD_LAYER) SBWG3A.148
! CHANGE IN PLANCK FUNCTION SBWG3A.149
& , DIFF_PLANCK_BAND_2(NPD_PROFILE, NPD_LAYER) SBWG3A.150
! 2x2ND DIFFERENCE OF PLANCKIAN IN BAND SBWG3A.151
LOGICAL !, INTENT(IN) SBWG3A.152
& L_IR_SOURCE_QUAD SBWG3A.153
! USE A QUADRATIC SOURCE FUNCTION SBWG3A.154
! SBWG3A.155
! Surface Properties SBWG3A.156
REAL !, INTENT(IN) SBWG3A.157
& ALBEDO_SURFACE_DIFF(NPD_PROFILE) SBWG3A.158
! DIFFUSE SURFACE ALBEDO SBWG3A.159
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) SBWG3A.160
! DIRECT SURFACE ALBEDO SBWG3A.161
& , THERMAL_GROUND_BAND(NPD_PROFILE) SBWG3A.162
! THERMAL SOURCE AT SURFACE IN BAND SBWG3A.163
! SBWG3A.164
! Clear-sky Optical Properties SBWG3A.165
REAL !, INTENT(IN) SBWG3A.166
& K_GREY_TOT_FREE(NPD_PROFILE, NPD_LAYER) SBWG3A.167
! FREE ABSORPTIVE EXTINCTION SBWG3A.168
& , K_EXT_SCAT_FREE(NPD_PROFILE, NPD_LAYER) SBWG3A.169
! FREE SCATTERING EXTINCTION SBWG3A.170
& , ASYMMETRY_FREE(NPD_PROFILE, NPD_LAYER) SBWG3A.171
! CLEAR-SKY ASYMMETRY SBWG3A.172
& , FORWARD_SCATTER_FREE(NPD_PROFILE, NPD_LAYER) SBWG3A.173
! FREE FORWARD SCATTERING SBWG3A.174
! SBWG3A.175
! Cloudy Properties SBWG3A.176
LOGICAL !, INTENT(IN) SBWG3A.177
& L_CLOUD SBWG3A.178
! CLOUDS REQUIRED SBWG3A.179
INTEGER !, INTENT(IN) SBWG3A.180
& I_CLOUD SBWG3A.181
! CLOUD SCHEME USED SBWG3A.182
! SBWG3A.183
! Cloud Geometry SBWG3A.184
INTEGER !, INTENT(IN) SBWG3A.185
& N_CLOUD_TOP SBWG3A.186
! TOPMOST CLOUDY LAYER SBWG3A.187
& , N_CLOUD_TYPE SBWG3A.188
! NUMBER OF TYPES OF CLOUDS SBWG3A.189
& , N_FREE_PROFILE(NPD_LAYER) SBWG3A.190
! NUMBER OF FREE PROFILES SBWG3A.191
& , I_FREE_PROFILE(NPD_PROFILE, NPD_LAYER) SBWG3A.192
! INDICES OF FREE PROFILES SBWG3A.193
& , N_CLOUD_PROFILE(NPD_LAYER) SBWG3A.194
! NUMBER OF CLOUDY PROFILES SBWG3A.195
& , I_CLOUD_PROFILE(NPD_PROFILE, NPD_LAYER) SBWG3A.196
! INDICES OF CLOUDY PROFILES SBWG3A.197
& , N_COLUMN(NPD_PROFILE) SBWG3A.198
! NUMBER OF COLUMNS REQUIRED SBWG3A.199
& , I_REGION_CLOUD(NPD_CLOUD_TYPE) ADB1F402.679
! REGIONS IN WHICH TYPES OF CLOUDS FALL ADB1F402.680
LOGICAL !, INTENT(IN) SBWG3A.200
& L_COLUMN(NPD_PROFILE, NPD_LAYER, NPD_COLUMN) SBWG3A.201
! FLAGS FOR CONTENTS OF COLUMNS SBWG3A.202
REAL !, INTENT(IN) SBWG3A.203
& W_FREE(NPD_PROFILE, NPD_LAYER) SBWG3A.204
! CLEAR-SKY FRACTION SBWG3A.205
& , W_CLOUD(NPD_PROFILE, NPD_LAYER) SBWG3A.206
! CLOUDY FRACTION SBWG3A.207
& , FRAC_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SBWG3A.208
! FRACTIONS OF TYPES OF CLOUDS SBWG3A.209
& , CLOUD_OVERLAP(NPD_PROFILE, 0: NPD_LAYER, NPD_OVERLAP_COEFF) SBWG3A.210
! COEFFICIENTS FOR TRANSFER FOR ENERGY AT INTERFACES SBWG3A.211
& , AREA_COLUMN(NPD_PROFILE, NPD_COLUMN) SBWG3A.212
! AREAS OF COLUMNS SBWG3A.213
& , FRAC_REGION(NPD_PROFILE, NPD_LAYER, NPD_REGION) ADB1F402.681
! FRACTIONS OF TOTAL CLOUD OCCUPIED BY EACH REGION ADB1F402.682
! SBWG3A.214
! Cloudy Optical Properties SBWG3A.215
REAL !, INTENT(IN) SBWG3A.216
& K_GREY_TOT_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SBWG3A.217
! CLOUDY ABSORPTIVE EXTINCTION SBWG3A.218
& , K_EXT_SCAT_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SBWG3A.219
! CLOUDY SCATTERING EXTINCTION SBWG3A.220
& , ASYMMETRY_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SBWG3A.221
! CLOUDY ASYMMETRY SBWG3A.222
& , FORWARD_SCATTER_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) SBWG3A.223
! CLOUDY FORWARD SCATTERING SBWG3A.224
! SBWG3A.225
! Calculated Fluxes SBWG3A.226
REAL !, INTENT(OUT) SBWG3A.227
& FLUX_DIRECT_BAND(NPD_PROFILE, 0: NPD_LAYER) SBWG3A.228
! DIRECT FLUX SBWG3A.229
& , FLUX_TOTAL_BAND(NPD_PROFILE, 2*NPD_LAYER+2) SBWG3A.230
! SBWG3A.231
! Flags for Clear-sky Fluxes SBWG3A.232
LOGICAL !, INTENT(IN) SBWG3A.233
& L_CLEAR SBWG3A.234
! CALCULATE NET CLEAR-SKY PROPERTIES SBWG3A.235
INTEGER !, INTENT(IN) SBWG3A.236
& I_SOLVER_CLEAR SBWG3A.237
! CLEAR SOLVER USED SBWG3A.238
! SBWG3A.239
! Calculated Clear-sky Fluxes SBWG3A.240
REAL !, INTENT(OUT) SBWG3A.241
& FLUX_DIRECT_CLEAR_BAND(NPD_PROFILE, 0: NPD_LAYER) SBWG3A.242
! CLEAR-SKY DIRECT FLUX SBWG3A.243
& , FLUX_TOTAL_CLEAR_BAND(NPD_PROFILE, 2*NPD_LAYER+2) SBWG3A.244
! CLEAR-SKY TOTAL FLUX SBWG3A.245
! SBWG3A.246
! Planckian Function SBWG3A.247
REAL !, INTENT(IN) SBWG3A.248
& PLANCK_SOURCE_BAND(NPD_PROFILE, 0: NPD_LAYER) SBWG3A.249
! PLANCKIAN SOURCE IN BAND SBWG3A.250
! SBWG3A.251
! SBWG3A.252
! SBWG3A.253
! LOCAL VARIABLES. SBWG3A.254
INTEGER SBWG3A.255
& I SBWG3A.256
! LOOP VARIABLE SBWG3A.257
& , L SBWG3A.258
! LOOP VARIABLE SBWG3A.259
REAL SBWG3A.260
& FLUX_INC_DIRECT(NPD_PROFILE) SBWG3A.261
! INCIDENT DIRECT FLUX SBWG3A.262
& , FLUX_INC_DOWN(NPD_PROFILE) SBWG3A.263
! INCIDENT DOWNWARD FLUX SBWG3A.264
& , SOURCE_GROUND(NPD_PROFILE) SBWG3A.265
! GROUND SOURCE FUNCTION SBWG3A.266
& , K_NULL(NPD_PROFILE, NPD_LAYER) SBWG3A.267
! NULL VECTOR FOR CALL TO SUBROUTINE SBWG3A.268
& , DUMMY_KE(NPD_PROFILE, NPD_LAYER) SBWG3A.269
! DUMMY ARRAY (NOT USED) SBWG3A.270
! SBWG3A.271
! SUBROUTINES CALLED: SBWG3A.272
EXTERNAL SBWG3A.273
& MONOCHROMATIC_FLUX SBWG3A.274
! SBWG3A.275
! SBWG3A.276
! SBWG3A.277
! SET THE APPROPRIATE TOTAL UPWARD AND DOWNWARD FLUXES SBWG3A.278
! AT THE BOUNDARIES. SBWG3A.279
! SBWG3A.280
IF (ISOLIR.EQ.IP_SOLAR) THEN SBWG3A.281
! VISIBLE REGION. SBWG3A.282
DO L=1, N_PROFILE SBWG3A.283
SOURCE_GROUND(L)=0.0E+00 SBWG3A.284
FLUX_INC_DOWN(L)=SOLAR_FLUX(L) SBWG3A.285
FLUX_INC_DIRECT(L)=SOLAR_FLUX(L) SBWG3A.286
ENDDO SBWG3A.287
ELSEIF (ISOLIR.EQ.IP_INFRA_RED) THEN SBWG3A.288
! INFRA-RED REGION. SBWG3A.289
DO L=1, N_PROFILE SBWG3A.290
FLUX_INC_DIRECT(L)=0.0E+00 SBWG3A.291
FLUX_DIRECT_BAND(L, N_LAYER)=0.0E+00 ADB1F401.920
FLUX_INC_DOWN(L)=-PLANCK_SOURCE_TOP(L) SBWG3A.292
SOURCE_GROUND(L)=THERMAL_GROUND_BAND(L) SBWG3A.293
& +(ALBEDO_SURFACE_DIFF(L)-1.0E+00) SBWG3A.294
& *PLANCK_SOURCE_BOTTOM(L) SBWG3A.295
ENDDO SBWG3A.296
IF (L_CLEAR) THEN ADB1F401.921
DO L=1, N_PROFILE ADB1F401.922
FLUX_DIRECT_CLEAR_BAND(L, N_LAYER)=0.0E+00 ADB1F401.923
ENDDO ADB1F401.924
ENDIF ADB1F401.925
ENDIF SBWG3A.297
! SBWG3A.298
DO I=1, N_LAYER SBWG3A.299
DO L=1, N_PROFILE SBWG3A.300
K_NULL(L, I)=0.0E+00 SBWG3A.301
ENDDO SBWG3A.302
ENDDO SBWG3A.303
! SBWG3A.304
! SBWG3A.305
CALL MONOCHROMATIC_FLUX
(IERR SBWG3A.306
! Atmospheric Properties SBWG3A.307
& , N_PROFILE, N_LAYER, D_MASS SBWG3A.308
! Angular Integration SBWG3A.309
& , I_ANGULAR_INTEGRATION, I_2STREAM, L_2_STREAM_CORRECT SBWG3A.310
& , L_RESCALE, N_ORDER_GAUSS SBWG3A.311
! Treatment of Scattering SBWG3A.312
& , I_SCATTER_METHOD_BAND SBWG3A.313
! Options for Solver SBWG3A.314
& , I_SOLVER, L_NET, N_AUGMENT ADB1F405.593
! Gaseous Propreties SBWG3A.316
& , K_NULL SBWG3A.317
! Options for Equivalent Extinction SBWG3A.318
& , .FALSE., DUMMY_KE SBWG3A.319
! Spectral Region SBWG3A.320
& , ISOLIR SBWG3A.321
! Infra-red Properties SBWG3A.322
& , DIFF_PLANCK_BAND SBWG3A.323
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_BAND_2 SBWG3A.324
! Conditions at TOA SBWG3A.325
& , SEC_0, FLUX_INC_DIRECT, FLUX_INC_DOWN SBWG3A.326
! Surface Properties SBWG3A.327
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR, SOURCE_GROUND SBWG3A.328
& , THERMAL_GROUND_BAND SBWG3A.329
! Clear-sky Optical Properties SBWG3A.330
& , K_GREY_TOT_FREE, K_EXT_SCAT_FREE SBWG3A.331
& , ASYMMETRY_FREE, FORWARD_SCATTER_FREE SBWG3A.332
! Cloudy Properties SBWG3A.333
& , L_CLOUD, I_CLOUD SBWG3A.334
! Cloud Geometry SBWG3A.335
& , N_CLOUD_TOP SBWG3A.336
& , N_CLOUD_TYPE, FRAC_CLOUD SBWG3A.337
& , I_REGION_CLOUD, FRAC_REGION ADB1F402.683
& , W_FREE, N_FREE_PROFILE, I_FREE_PROFILE SBWG3A.338
& , W_CLOUD, N_CLOUD_PROFILE, I_CLOUD_PROFILE SBWG3A.339
& , CLOUD_OVERLAP SBWG3A.340
& , N_COLUMN, L_COLUMN, AREA_COLUMN SBWG3A.341
! Cloudy Optical Properties SBWG3A.342
& , K_GREY_TOT_CLOUD, K_EXT_SCAT_CLOUD SBWG3A.343
& , ASYMMETRY_CLOUD, FORWARD_SCATTER_CLOUD SBWG3A.344
! Flxues Calculated SBWG3A.345
& , FLUX_DIRECT_BAND, FLUX_TOTAL_BAND SBWG3A.346
! Flags for Clear-sky Calculations SBWG3A.347
& , L_CLEAR, I_SOLVER_CLEAR SBWG3A.348
! Clear-sky Fluxes Calculated SBWG3A.349
& , FLUX_DIRECT_CLEAR_BAND, FLUX_TOTAL_CLEAR_BAND SBWG3A.350
! Planckian Function SBWG3A.351
& , PLANCK_SOURCE_BAND SBWG3A.352
! Dimensions of Arrays SBWG3A.353
& , NPD_PROFILE, NPD_LAYER, NPD_COLUMN SBWG3A.354
& ) SBWG3A.355
! SBWG3A.356
! SBWG3A.357
! SBWG3A.358
RETURN SBWG3A.359
END SBWG3A.360
*ENDIF DEF,A01_3A,OR,DEF,A02_3A SBWG3A.361
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.84