*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.51
*IF DEF,A01_3A,OR,DEF,A02_3A MXCOL3A.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13518
C GTS2F400.13519
C Use, duplication or disclosure of this code is subject to the GTS2F400.13520
C restrictions as set forth in the contract. GTS2F400.13521
C GTS2F400.13522
C Meteorological Office GTS2F400.13523
C London Road GTS2F400.13524
C BRACKNELL GTS2F400.13525
C Berkshire UK GTS2F400.13526
C RG12 2SZ GTS2F400.13527
C GTS2F400.13528
C If no contract has been raised with this copy of the code, the use, GTS2F400.13529
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13530
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13531
C Modelling at the above address. GTS2F400.13532
C ******************************COPYRIGHT****************************** GTS2F400.13533
C GTS2F400.13534
!+ Subroutine to solve the two-stream equations in a mixed column. MXCOL3A.3
! MXCOL3A.4
! Method: MXCOL3A.5
! The two-stream coefficients are calculated in clear regions MXCOL3A.6
! and in stratiform and convective clouds. From these MXCOL3A.7
! coefficients transmission and reflection coefficients are MXCOL3A.8
! determined. The coefficients for convective and stratiform MXCOL3A.9
! clouds are appropriately mixed to form single cloudy values MXCOL3A.10
! and an appropriate solver is called. MXCOL3A.11
! MXCOL3A.12
! Current Owner of Code: J. M. Edwards MXCOL3A.13
! MXCOL3A.14
! History: MXCOL3A.15
! Version Date Comment MXCOL3A.16
! 4.0 27-07-95 Original Code MXCOL3A.17
! (J. M. Edwards) MXCOL3A.18
! 4.1 10-04-96 New solver added. ADB1F401.615
! (J. M. Edwards) ADB1F401.616
! 4.5 18-05-98 Code for obsolete ADB1F405.391
! solver removed. ADB1F405.392
! (J. M. Edwards) ADB1F405.393
! MXCOL3A.19
! Description of Code: MXCOL3A.20
! FORTRAN 77 with extensions listed in documentation. MXCOL3A.21
! MXCOL3A.22
!- --------------------------------------------------------------------- MXCOL3A.23
SUBROUTINE MIX_COLUMN(IERR 1,10MXCOL3A.24
! Atmospheric Properties MXCOL3A.25
& , N_PROFILE, N_LAYER MXCOL3A.26
! Two-stream Scheme MXCOL3A.27
& , I_2STREAM MXCOL3A.28
! Corrections to Two-stream Equations MXCOL3A.29
& , L_2_STREAM_CORRECT, PLANCK_SOURCE, GROUND_EMISSION MXCOL3A.30
! Options for Solver MXCOL3A.31
& , I_SOLVER, L_NET ADB1F405.394
! Options for Equivalent Extinction MXCOL3A.33
& , L_SCALE_SOLAR, ADJUST_SOLAR_KE MXCOL3A.34
! Spectral Region MXCOL3A.35
& , ISOLIR MXCOL3A.36
! Infra-red Properties MXCOL3A.37
& , DIFF_PLANCK MXCOL3A.38
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_2 MXCOL3A.39
! Conditions at TOA MXCOL3A.40
& , FLUX_INC_DOWN, FLUX_INC_DIRECT, SEC_0 MXCOL3A.41
! Conditions at Surface MXCOL3A.42
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR, SOURCE_GROUND MXCOL3A.43
! Clear-sky Single Scattering Properties MXCOL3A.44
& , TAU_FREE, OMEGA_FREE, ASYMMETRY_FREE MXCOL3A.45
! Cloud Geometry MXCOL3A.46
& , N_CLOUD_TOP MXCOL3A.47
& , N_CLOUD_TYPE, FRAC_CLOUD MXCOL3A.48
& , W_FREE, N_FREE_PROFILE, I_FREE_PROFILE MXCOL3A.49
& , W_CLOUD, N_CLOUD_PROFILE, I_CLOUD_PROFILE MXCOL3A.50
& , CLOUD_OVERLAP MXCOL3A.51
! Cloudy Optical Properties MXCOL3A.52
& , TAU_CLOUD, OMEGA_CLOUD, ASYMMETRY_CLOUD MXCOL3A.53
! Fluxes Calculated MXCOL3A.54
& , FLUX_DIRECT, FLUX_TOTAL MXCOL3A.55
! Flags for Clear-sky Calculations MXCOL3A.56
& , L_CLEAR, I_SOLVER_CLEAR MXCOL3A.57
! Clear-sky Fluxes Calculated MXCOL3A.58
& , FLUX_DIRECT_CLEAR, FLUX_TOTAL_CLEAR MXCOL3A.59
! Dimensions of Arrays MXCOL3A.60
& , NPD_PROFILE, NPD_LAYER MXCOL3A.61
& ) MXCOL3A.62
! MXCOL3A.63
! MXCOL3A.64
! MXCOL3A.65
IMPLICIT NONE MXCOL3A.66
! MXCOL3A.67
! MXCOL3A.68
! SIZES OF DUMMY ARRAYS. MXCOL3A.69
INTEGER !, INTENT(IN) MXCOL3A.70
& NPD_PROFILE MXCOL3A.71
! MAXIMUM NUMBER OF PROFILES MXCOL3A.72
& , NPD_LAYER MXCOL3A.73
! MAXIMUM NUMBER OF LAYERS MXCOL3A.74
! MXCOL3A.75
! INCLUDE COMDECKS. MXCOL3A.76
*CALL STDIO3A
MXCOL3A.77
*CALL DIMFIX3A
MXCOL3A.78
*CALL ERROR3A
MXCOL3A.79
*CALL PRMCH3A
MXCOL3A.80
*CALL PRECSN3A
MXCOL3A.81
*CALL SPCRG3A
MXCOL3A.82
*CALL SOLVER3A
MXCOL3A.83
*CALL CLCFPT3A
MXCOL3A.84
! MXCOL3A.85
! DUMMY VARIABLES. MXCOL3A.86
INTEGER !, INTENT(IN) MXCOL3A.87
& N_PROFILE MXCOL3A.88
! NUMBER OF PROFILES MXCOL3A.89
& , N_LAYER MXCOL3A.90
! NUMBER OF LAYERS MXCOL3A.91
& , N_CLOUD_TOP MXCOL3A.92
! TOP CLOUDY LAYER MXCOL3A.93
& , N_CLOUD_TYPE MXCOL3A.94
! NUMBER OF TYPES OF CLOUDS MXCOL3A.95
& , N_FREE_PROFILE(NPD_LAYER) MXCOL3A.96
! NUMBER OF FREE PROFILES MXCOL3A.97
& , I_FREE_PROFILE(NPD_PROFILE, NPD_LAYER) MXCOL3A.98
! INDICES OF FREE PROFILES MXCOL3A.99
& , N_CLOUD_PROFILE(NPD_LAYER) MXCOL3A.100
! NUMBER OF CLOUDY PROFILES MXCOL3A.101
& , I_CLOUD_PROFILE(NPD_PROFILE, NPD_LAYER) MXCOL3A.102
! INDICES OF CLOUDY PROFILES MXCOL3A.103
& , ISOLIR MXCOL3A.104
! SPECTRAL REGION MXCOL3A.105
& , I_2STREAM MXCOL3A.106
! TWO-STREAM SCHEME MXCOL3A.107
& , I_SOLVER MXCOL3A.108
! SOLVER USED MXCOL3A.109
& , I_SOLVER_CLEAR MXCOL3A.112
! SOLVER FOR CLEAR-SKY FLUXES MXCOL3A.113
INTEGER !, INTENT(OUT) MXCOL3A.114
& IERR MXCOL3A.115
! ERROR FLAG MXCOL3A.116
LOGICAL !, INTENT(IN) MXCOL3A.117
& L_NET MXCOL3A.118
! CALCULATE NET FLUXES MXCOL3A.119
& , L_CLEAR MXCOL3A.120
! CALCULATE CLEAR-SKY FLUXES MXCOL3A.121
& , L_SCALE_SOLAR MXCOL3A.122
! FLAG TO SCALE SOLAR MXCOL3A.123
& , L_IR_SOURCE_QUAD MXCOL3A.124
! USE QUADRATIC SOURCE TERM MXCOL3A.125
& , L_2_STREAM_CORRECT MXCOL3A.126
! EDGE CORRECTION TO 2-STREAM MXCOL3A.127
! MXCOL3A.128
! OPTICAL PROPERTIES: MXCOL3A.129
REAL !, INTENT(IN) MXCOL3A.130
& TAU_FREE(NPD_PROFILE, NPD_LAYER) MXCOL3A.131
! FREE OPTICAL DEPTH MXCOL3A.132
& , OMEGA_FREE(NPD_PROFILE, NPD_LAYER) MXCOL3A.133
! FREE ALBEDO OF SINGLE SCATTERING MXCOL3A.134
& , ASYMMETRY_FREE(NPD_PROFILE, NPD_LAYER) MXCOL3A.135
! CLEAR-SKY ASYMMETRY MXCOL3A.136
& , TAU_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) MXCOL3A.137
! CLOUDY OPTICAL DEPTH MXCOL3A.138
& , OMEGA_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) MXCOL3A.139
! CLOUDY ALBEDO OF SINGLE SCATTERING MXCOL3A.140
& , ASYMMETRY_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) MXCOL3A.141
! CLOUDY ASYMMETRY MXCOL3A.142
! MXCOL3A.143
! CLOUD GEOMETRY: MXCOL3A.144
REAL !, INTENT(IN) MXCOL3A.145
& W_CLOUD(NPD_PROFILE, NPD_LAYER) MXCOL3A.146
! CLOUDY FRACTIONS IN EACH LAYER MXCOL3A.147
& , W_FREE(NPD_PROFILE, NPD_LAYER) MXCOL3A.148
! CLEAR SKY FRACTIONS IN EACH LAYER MXCOL3A.149
& , FRAC_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) MXCOL3A.150
! FRACTIONS OF DIFFERENT TYPES OF CLOUD MXCOL3A.151
& , CLOUD_OVERLAP(NPD_PROFILE, 0: NPD_LAYER, NPD_OVERLAP_COEFF) MXCOL3A.152
! ENERGY TRANSFER COEFFICIENTS MXCOL3A.153
REAL !, INTENT(IN) MXCOL3A.154
& SEC_0(NPD_PROFILE) MXCOL3A.155
! SECANT OF SOLAR ZENITH ANGLE MXCOL3A.156
& , ALBEDO_SURFACE_DIFF(NPD_PROFILE) MXCOL3A.157
! DIFFUSE ALBEDO MXCOL3A.158
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) MXCOL3A.159
! DIRECT ALBEDO MXCOL3A.160
& , FLUX_INC_DOWN(NPD_PROFILE) MXCOL3A.161
! INCIDENT TOTAL FLUX MXCOL3A.162
& , FLUX_INC_DIRECT(NPD_PROFILE) MXCOL3A.163
! INCIDENT DIRECT FLUX MXCOL3A.164
& , DIFF_PLANCK(NPD_PROFILE, NPD_LAYER) MXCOL3A.165
! CHANGE IN PLANCK FUNCTION MXCOL3A.166
& , SOURCE_GROUND(NPD_PROFILE) MXCOL3A.167
! FLUX FROM SURFACE MXCOL3A.168
& , ADJUST_SOLAR_KE(NPD_PROFILE, NPD_LAYER) MXCOL3A.169
! ADJUSTMENT OF SOLAR BEAM WITH EQUIVALENT EXTINCTION MXCOL3A.170
& , DIFF_PLANCK_2(NPD_PROFILE, NPD_LAYER) MXCOL3A.171
! 2x2ND DIFFERENCE OF PLANCKIAN MXCOL3A.172
& , PLANCK_SOURCE(NPD_PROFILE, 0: NPD_LAYER) MXCOL3A.173
! PLANCKIAN SOURCE FUNCTION MXCOL3A.174
& , GROUND_EMISSION(NPD_PROFILE) MXCOL3A.175
! TOTAL FLUX EMITTED FROM GROUND MXCOL3A.176
! MXCOL3A.177
! FLUXES CALCULATED MXCOL3A.178
REAL !, INTENT(OUT) MXCOL3A.179
& FLUX_DIRECT(NPD_PROFILE, 0: NPD_LAYER) MXCOL3A.180
! DIRECT FLUX MXCOL3A.181
& , FLUX_TOTAL(NPD_PROFILE, 2*NPD_LAYER+2) MXCOL3A.182
! LONG FLUX VECTOR MXCOL3A.183
& , FLUX_DIRECT_CLEAR(NPD_PROFILE, 0: NPD_LAYER) MXCOL3A.184
! CLEAR DIRECT FLUX MXCOL3A.185
& , FLUX_TOTAL_CLEAR(NPD_PROFILE, 2*NPD_LAYER+2) MXCOL3A.186
! CLEAR TOTAL FLUX MXCOL3A.187
! MXCOL3A.188
! MXCOL3A.189
! MXCOL3A.190
! LOCAL VARIABALES. MXCOL3A.191
INTEGER MXCOL3A.192
& N_SOURCE_COEFF MXCOL3A.193
! NUMBER OF SOURCE COEFFICIENTS MXCOL3A.194
& , N_EQUATION MXCOL3A.195
! NUMBER OF EQUATIONS MXCOL3A.196
& , I MXCOL3A.197
! LOOP VARIABLE MXCOL3A.198
& , L MXCOL3A.199
! LOOP VARIABLE MXCOL3A.200
! MXCOL3A.201
! MXCOL3A.202
! CLEAR-SKY COEFFICIENTS: MXCOL3A.203
REAL MXCOL3A.204
& TRANS_FREE(NPD_PROFILE, NPD_LAYER) MXCOL3A.205
! FREE TRANSMISSION OF LAYER MXCOL3A.206
& , REFLECT_FREE(NPD_PROFILE, NPD_LAYER) MXCOL3A.207
! FREE REFLECTANCE OF LAYER MXCOL3A.208
& , TRANS_0_FREE(NPD_PROFILE, NPD_LAYER) MXCOL3A.209
! FREE DIRECT TRANSMISSION OF LAYER MXCOL3A.210
& , SOURCE_COEFF_FREE(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) MXCOL3A.211
! FREE SOURCE COEFFICIENTS MXCOL3A.212
& , S_DOWN_FREE(NPD_PROFILE, NPD_LAYER) MXCOL3A.213
! FREE DOWNWARD SOURCE MXCOL3A.214
& , S_UP_FREE(NPD_PROFILE, NPD_LAYER) MXCOL3A.215
! FREE UPWARD SOURCE MXCOL3A.216
& , S_DOWN_CLEAR(NPD_PROFILE, NPD_LAYER) MXCOL3A.217
! CLEAR DOWNWARD SOURCE MXCOL3A.218
& , S_UP_CLEAR(NPD_PROFILE, NPD_LAYER) MXCOL3A.219
! CLEAR UPWARD SOURCE MXCOL3A.220
! MXCOL3A.221
! CLOUDY COEFFICIENTS: MXCOL3A.222
REAL MXCOL3A.223
& TRANS_CLOUD(NPD_PROFILE, NPD_LAYER) MXCOL3A.224
! CLOUDY TRANSMISSION OF LAYER MXCOL3A.225
& , REFLECT_CLOUD(NPD_PROFILE, NPD_LAYER) MXCOL3A.226
! CLOUDY REFLECTANCE OF LAYER MXCOL3A.227
& , TRANS_0_CLOUD(NPD_PROFILE, NPD_LAYER) MXCOL3A.228
! CLOUDY DIRECT TRANSMISSION OF LAYER MXCOL3A.229
& , SOURCE_COEFF_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) MXCOL3A.230
! CLOUDY SOURCE COEFFICIENTS MXCOL3A.231
& , S_DOWN_CLOUD(NPD_PROFILE, NPD_LAYER) MXCOL3A.232
! CLOUDY DOWNWARD SOURCE MXCOL3A.233
& , S_UP_CLOUD(NPD_PROFILE, NPD_LAYER) MXCOL3A.234
! CLOUDY UPWARD SOURCE MXCOL3A.235
! MXCOL3A.236
! SOURCE FUNCTIONS AT THE CROUND ADB1F401.617
REAL ADB1F401.618
& SOURCE_GROUND_FREE(NPD_PROFILE) ADB1F401.619
! SOURCE FROM GROUND UNDER CLEAR SKIES ADB1F401.620
& , SOURCE_GROUND_CLOUD(NPD_PROFILE) ADB1F401.621
! SOURCE FROM GROUND UNDER CLOUDY SKIES ADB1F401.622
& , FLUX_DIRECT_GROUND_CLOUD(NPD_PROFILE) ADB1F401.623
! DIRECT FLUX AT GROUND UNDER CLOUDY SKIES ADB1F401.624
! ADB1F401.625
! MXCOL3A.247
! NUMERICAL ARRAYS: MXCOL3A.248
REAL MXCOL3A.249
& A5(NPD_PROFILE, 5, 2*NPD_LAYER+2) MXCOL3A.250
! PENTADIAGONAL MATRIX MXCOL3A.251
& , B(NPD_PROFILE, 2*NPD_LAYER+2) MXCOL3A.252
! RHS OF MATRIX EQUATION MXCOL3A.253
& , WORK(NPD_PROFILE) MXCOL3A.254
! WORKING ARRAY FOR SOLVER MXCOL3A.255
! MXCOL3A.256
! FUNCTIONS CALLED: MXCOL3A.257
INTEGER MXCOL3A.258
& SET_N_SOURCE_COEFF MXCOL3A.259
! FUNCTION TO SET NUMBER OF SOURCE COEFFICIENTS MXCOL3A.260
! MXCOL3A.261
! SUBROUTINES CALLED: MXCOL3A.262
EXTERNAL MXCOL3A.263
& TWO_COEFF, TWO_COEFF_CLOUD, IR_SOURCE, MIXED_SOLAR_SOURCE MXCOL3A.264
& , BAND_SOLVER, MIX_COLUMN_FULL, MIX_APP_SCAT ADB1F405.395
& , CLEAR_SUPPLEMENT MXCOL3A.267
! MXCOL3A.268
! MXCOL3A.269
! MXCOL3A.270
! CALCULATE THE TRANSMISSION AND REFLECTION COEFFICIENTS AND MXCOL3A.271
! SOURCE TERMS FOR THE CLEAR AND CLOUDY PARTS OF THE COLUMN MXCOL3A.272
! MXCOL3A.273
! SET THE NUMBER OF SOURCE COEFFICIENTS FOR THE APPROXIMATION MXCOL3A.274
N_SOURCE_COEFF=SET_N_SOURCE_COEFF
(ISOLIR, L_IR_SOURCE_QUAD) MXCOL3A.275
! MXCOL3A.276
CALL TWO_COEFF
(IERR MXCOL3A.277
& , N_PROFILE, 1, N_LAYER MXCOL3A.278
& , I_2STREAM, L_IR_SOURCE_QUAD MXCOL3A.279
& , ASYMMETRY_FREE, OMEGA_FREE, TAU_FREE MXCOL3A.280
& , ISOLIR, SEC_0 MXCOL3A.281
& , TRANS_FREE, REFLECT_FREE, TRANS_0_FREE MXCOL3A.282
& , SOURCE_COEFF_FREE MXCOL3A.283
& , NPD_PROFILE, NPD_LAYER MXCOL3A.284
& ) MXCOL3A.285
IF (IERR.NE.I_NORMAL) RETURN MXCOL3A.286
! MXCOL3A.287
! MXCOL3A.288
! INFRA-RED SOURCE TERMS DEPEND ONLY ON THE LAYER AND MAY BE MXCOL3A.289
! CALCULATED NOW. SOLAR TERMS DEPEND ON CONDITIONS IN CLOUD MXCOL3A.290
! IN OVERLYING LAYERS AND MUST BE CALCULATED LATER. MXCOL3A.291
! MXCOL3A.292
IF (ISOLIR.EQ.IP_INFRA_RED) THEN MXCOL3A.293
! MXCOL3A.294
CALL IR_SOURCE
(N_PROFILE, 1, N_LAYER MXCOL3A.295
& , SOURCE_COEFF_FREE, DIFF_PLANCK MXCOL3A.296
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_2 MXCOL3A.297
& , L_2_STREAM_CORRECT, PLANCK_SOURCE MXCOL3A.298
& , GROUND_EMISSION, N_LAYER MXCOL3A.299
& , TAU_FREE, TRANS_FREE MXCOL3A.300
& , S_DOWN_FREE, S_UP_FREE MXCOL3A.301
& , NPD_PROFILE, NPD_LAYER MXCOL3A.302
& ) MXCOL3A.303
! MXCOL3A.304
! IF A CLEAR-SKY CALCULATION IS REQUIRED THESE SOURCE TERMS MUST MXCOL3A.305
! BE STORED. MXCOL3A.306
IF (L_CLEAR) THEN MXCOL3A.307
DO I=1, N_LAYER MXCOL3A.308
DO L=1, N_PROFILE MXCOL3A.309
S_DOWN_CLEAR(L, I)=S_DOWN_FREE(L, I) MXCOL3A.310
S_UP_CLEAR(L, I)=S_UP_FREE(L, I) MXCOL3A.311
ENDDO MXCOL3A.312
ENDDO MXCOL3A.313
ENDIF MXCOL3A.314
! MXCOL3A.315
! SCALE THE SOURCES BY THE CLEAR-SKY FRACTIONS IN THE CLOUDY MXCOL3A.316
! LAYERS. IN HIGHER LAYERS THE CLEAR-SKY FRACTION IS 1. MXCOL3A.317
DO I=N_CLOUD_TOP, N_LAYER MXCOL3A.318
DO L=1, N_PROFILE MXCOL3A.319
S_DOWN_FREE(L, I)=W_FREE(L, I)*S_DOWN_FREE(L, I) MXCOL3A.320
S_UP_FREE(L, I)=W_FREE(L, I)*S_UP_FREE(L, I) MXCOL3A.321
ENDDO MXCOL3A.322
ENDDO MXCOL3A.323
! MXCOL3A.324
ENDIF MXCOL3A.325
! MXCOL3A.326
! MXCOL3A.327
! MXCOL3A.328
! REPEAT THE CALCULATION FOR CLOUDY REGIONS. MXCOL3A.329
! MXCOL3A.330
! MXCOL3A.331
CALL TWO_COEFF_CLOUD
(IERR MXCOL3A.332
& , N_PROFILE, N_CLOUD_TOP, N_LAYER MXCOL3A.333
& , I_2STREAM, L_IR_SOURCE_QUAD, N_SOURCE_COEFF MXCOL3A.334
& , N_CLOUD_TYPE, FRAC_CLOUD MXCOL3A.335
& , ASYMMETRY_CLOUD, OMEGA_CLOUD, TAU_CLOUD MXCOL3A.336
& , ISOLIR, SEC_0 MXCOL3A.337
& , TRANS_CLOUD, REFLECT_CLOUD, TRANS_0_CLOUD MXCOL3A.338
& , SOURCE_COEFF_CLOUD MXCOL3A.339
& , NPD_PROFILE, NPD_LAYER MXCOL3A.340
& ) MXCOL3A.341
IF (IERR.NE.I_NORMAL) RETURN MXCOL3A.342
! MXCOL3A.343
! MXCOL3A.344
IF (ISOLIR.EQ.IP_INFRA_RED) THEN MXCOL3A.345
! MXCOL3A.346
! EDGE CORRECTIONS FOR THE TWO-STREAM EQUATIONS DO NOT MXCOL3A.347
! REALLY FIT WITH THIS METHOD OF TREATING CLOUDS. OPTICAL MXCOL3A.348
! DEPTHS AND TRANSMISSIONS MUST BE PASSED TO THE SUBROUTINE MXCOL3A.349
! TO FILL THE ARGUMENT LIST, BUT IT IS NOT INTENDED THAT MXCOL3A.350
! THESE ARRAYS WILL BE USED. MXCOL3A.351
! MXCOL3A.352
CALL IR_SOURCE
(N_PROFILE, N_CLOUD_TOP, N_LAYER MXCOL3A.353
& , SOURCE_COEFF_CLOUD, DIFF_PLANCK MXCOL3A.354
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_2 MXCOL3A.355
& , L_2_STREAM_CORRECT, PLANCK_SOURCE MXCOL3A.356
& , GROUND_EMISSION, N_LAYER MXCOL3A.357
& , TAU_CLOUD, TRANS_CLOUD MXCOL3A.358
& , S_DOWN_CLOUD, S_UP_CLOUD MXCOL3A.359
& , NPD_PROFILE, NPD_LAYER MXCOL3A.360
& ) MXCOL3A.361
! MXCOL3A.362
! MXCOL3A.363
DO I=N_CLOUD_TOP, N_LAYER MXCOL3A.364
DO L=1, N_PROFILE MXCOL3A.365
S_DOWN_CLOUD(L, I)=W_CLOUD(L, I)*S_DOWN_CLOUD(L, I) MXCOL3A.366
S_UP_CLOUD(L, I)=W_CLOUD(L, I)*S_UP_CLOUD(L, I) MXCOL3A.367
ENDDO MXCOL3A.368
ENDDO MXCOL3A.369
! MXCOL3A.370
ENDIF MXCOL3A.371
! MXCOL3A.372
! MXCOL3A.373
! CALCULATE THE APPROPRIATE SOURCE TERMS FOR THE SOLAR: CLOUDY MXCOL3A.374
! AND CLEAR PROPERTIES ARE BOTH NEEDED HERE. MXCOL3A.375
! MXCOL3A.376
IF (ISOLIR.EQ.IP_SOLAR) THEN MXCOL3A.377
! MXCOL3A.378
CALL MIXED_SOLAR_SOURCE
(N_PROFILE, N_LAYER, N_CLOUD_TOP MXCOL3A.379
& , FLUX_INC_DIRECT MXCOL3A.380
& , L_SCALE_SOLAR, ADJUST_SOLAR_KE MXCOL3A.381
& , TRANS_0_FREE, SOURCE_COEFF_FREE MXCOL3A.382
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GFF) MXCOL3A.383
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GFC) MXCOL3A.384
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GCF) MXCOL3A.385
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GCC) MXCOL3A.386
& , TRANS_0_CLOUD, SOURCE_COEFF_CLOUD MXCOL3A.387
& , FLUX_DIRECT MXCOL3A.388
& , FLUX_DIRECT_GROUND_CLOUD ADB1F401.626
& , S_UP_FREE, S_DOWN_FREE MXCOL3A.389
& , S_UP_CLOUD, S_DOWN_CLOUD MXCOL3A.390
& , NPD_PROFILE, NPD_LAYER MXCOL3A.391
& ) MXCOL3A.392
ENDIF MXCOL3A.393
! MXCOL3A.394
! MXCOL3A.395
! MXCOL3A.396
! FORMULATE THE MATRIX EQUATIONS FOR THE FLUXES. ADB1F405.396
! MXCOL3A.398
IF (I_SOLVER.EQ.IP_SOLVER_MIX_APP_SCAT) THEN ADB1F405.397
! MXCOL3A.485
CALL MIX_APP_SCAT
(N_PROFILE, N_LAYER, N_CLOUD_TOP MXCOL3A.486
& , TRANS_FREE, REFLECT_FREE, S_DOWN_FREE, S_UP_FREE MXCOL3A.487
& , TRANS_CLOUD, REFLECT_CLOUD MXCOL3A.488
& , S_DOWN_CLOUD, S_UP_CLOUD MXCOL3A.489
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GFF) MXCOL3A.490
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GFC) MXCOL3A.491
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GCF) MXCOL3A.492
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GCC) MXCOL3A.493
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_BFF) MXCOL3A.494
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_BFC) MXCOL3A.495
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_BCF) MXCOL3A.496
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_BCC) MXCOL3A.497
& , L_NET MXCOL3A.498
& , FLUX_INC_DOWN MXCOL3A.499
& , SOURCE_GROUND, ALBEDO_SURFACE_DIFF MXCOL3A.500
& , FLUX_TOTAL ADB1F401.627
& , NPD_PROFILE, NPD_LAYER ADB1F401.628
& ) ADB1F401.629
! ADB1F401.630
ELSE IF (I_SOLVER.EQ.IP_SOLVER_MIX_DIRECT) THEN ADB1F405.398
! ADB1F401.633
! SET THE PARTITIONED SOURCE FUNCTIONS AT THE GROUND. ADB1F401.634
IF (ISOLIR.EQ.IP_SOLAR) THEN ADB1F401.635
DO L=1, N_PROFILE ADB1F401.636
SOURCE_GROUND_FREE(L)=(ALBEDO_SURFACE_DIR(L) ADB1F401.637
& -ALBEDO_SURFACE_DIFF(L)) ADB1F401.638
& *(FLUX_DIRECT(L, N_LAYER) ADB1F401.639
& -FLUX_DIRECT_GROUND_CLOUD(L)) ADB1F401.640
SOURCE_GROUND_CLOUD(L)=(ALBEDO_SURFACE_DIR(L) ADB1F401.641
& -ALBEDO_SURFACE_DIFF(L)) ADB1F401.642
& *FLUX_DIRECT_GROUND_CLOUD(L) ADB1F401.643
ENDDO ADB1F401.644
ELSE ADB1F401.645
DO L=1, N_PROFILE ADB1F401.646
SOURCE_GROUND_FREE(L) ADB1F401.647
& =CLOUD_OVERLAP(L, N_LAYER, IP_CLOVLP_BFF) ADB1F401.648
& *SOURCE_GROUND(L) ADB1F401.649
SOURCE_GROUND_CLOUD(L) ADB1F401.650
& =CLOUD_OVERLAP(L, N_LAYER, IP_CLOVLP_BCF) ADB1F401.651
& *SOURCE_GROUND(L) ADB1F401.652
ENDDO ADB1F401.653
ENDIF ADB1F401.654
! ADB1F401.655
CALL SOLVER_MIX_DIRECT
(N_PROFILE, N_LAYER, N_CLOUD_TOP ADB1F401.656
& , TRANS_FREE, REFLECT_FREE, S_DOWN_FREE, S_UP_FREE ADB1F401.657
& , TRANS_CLOUD, REFLECT_CLOUD ADB1F401.658
& , S_DOWN_CLOUD, S_UP_CLOUD ADB1F401.659
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GFF) ADB1F401.660
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GFC) ADB1F401.661
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GCF) ADB1F401.662
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GCC) ADB1F401.663
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_BFF) ADB1F401.664
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_BFC) ADB1F401.665
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_BCF) ADB1F401.666
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_BCC) ADB1F401.667
& , L_NET ADB1F401.668
& , FLUX_INC_DOWN ADB1F401.669
& , SOURCE_GROUND_FREE, SOURCE_GROUND_CLOUD ADB1F401.670
& , ALBEDO_SURFACE_DIFF ADB1F401.671
& , FLUX_TOTAL MXCOL3A.501
& , NPD_PROFILE, NPD_LAYER MXCOL3A.502
& ) MXCOL3A.532
! MXCOL3A.533
ELSE IF (I_SOLVER.EQ.IP_SOLVER_MIX_11) THEN MXCOL3A.534
! MXCOL3A.535
CALL MIX_COLUMN_FULL
(N_PROFILE, N_LAYER, N_CLOUD_TOP MXCOL3A.536
& , TRANS_FREE, REFLECT_FREE, S_DOWN_FREE, S_UP_FREE MXCOL3A.537
& , TRANS_CLOUD, REFLECT_CLOUD MXCOL3A.538
& , S_DOWN_CLOUD, S_UP_CLOUD MXCOL3A.539
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GM) MXCOL3A.540
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_GP) MXCOL3A.541
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_BM) MXCOL3A.542
& , CLOUD_OVERLAP(1, 0, IP_CLOVLP_BP) MXCOL3A.543
& , FLUX_INC_DOWN MXCOL3A.544
& , SOURCE_GROUND, ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR MXCOL3A.545
& , FLUX_DIRECT(1, N_LAYER) MXCOL3A.546
& , FLUX_TOTAL MXCOL3A.547
& , NPD_PROFILE, NPD_LAYER MXCOL3A.548
& ) MXCOL3A.549
! MXCOL3A.550
ELSE MXCOL3A.551
! MXCOL3A.552
WRITE(IU_ERR, '(/A)') MXCOL3A.553
& '***ERROR: THE SOLVER SPECIFIED IS NOT VALID HERE.' MXCOL3A.554
IERR=I_ERR_FATAL MXCOL3A.555
RETURN MXCOL3A.556
! MXCOL3A.557
ENDIF MXCOL3A.558
! MXCOL3A.559
! MXCOL3A.560
! MXCOL3A.561
IF (L_CLEAR) THEN MXCOL3A.562
! MXCOL3A.563
CALL CLEAR_SUPPLEMENT
(IERR, N_PROFILE, N_LAYER, I_SOLVER_CLEAR MXCOL3A.564
& , TRANS_FREE, REFLECT_FREE, TRANS_0_FREE, SOURCE_COEFF_FREE MXCOL3A.565
& , ISOLIR, FLUX_INC_DIRECT, FLUX_INC_DOWN MXCOL3A.566
& , S_DOWN_CLEAR, S_UP_CLEAR MXCOL3A.567
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR MXCOL3A.568
& , SOURCE_GROUND MXCOL3A.569
& , L_SCALE_SOLAR, ADJUST_SOLAR_KE MXCOL3A.570
& , FLUX_DIRECT_CLEAR, FLUX_TOTAL_CLEAR MXCOL3A.571
& , NPD_PROFILE, NPD_LAYER MXCOL3A.572
& ) MXCOL3A.573
ENDIF MXCOL3A.574
! MXCOL3A.575
! MXCOL3A.576
! MXCOL3A.577
RETURN MXCOL3A.578
END MXCOL3A.579
*ENDIF DEF,A01_3A,OR,DEF,A02_3A MXCOL3A.580
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.52