SUBROUTINE CLOUD_COLUMN(IERR 1,10CLCOL3A.23
! Atmospheric Properties CLCOL3A.24
& , N_PROFILE, N_LAYER CLCOL3A.25
! Two-stream Scheme CLCOL3A.26
& , I_2STREAM CLCOL3A.27
! Corrections to Two-stream Equations CLCOL3A.28
& , L_2_STREAM_CORRECT, PLANCK_SOURCE, GROUND_EMISSION CLCOL3A.29
! Options for Solver CLCOL3A.30
& , I_SOLVER, N_AUGMENT CLCOL3A.31
! Options for Equivalent Extinction CLCOL3A.32
& , L_SCALE_SOLAR, ADJUST_SOLAR_KE CLCOL3A.33
! Spectral Region CLCOL3A.34
& , ISOLIR CLCOL3A.35
! Infra-red Properties CLCOL3A.36
& , DIFF_PLANCK CLCOL3A.37
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_2 CLCOL3A.38
! Conditions at TOA CLCOL3A.39
& , FLUX_INC_DOWN, FLUX_INC_DIRECT, SEC_0 CLCOL3A.40
! Conditions at Surface CLCOL3A.41
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR, SOURCE_GROUND CLCOL3A.42
! Clear-sky Single Scattering Properties CLCOL3A.43
& , TAU_FREE, OMEGA_FREE, ASYMMETRY_FREE CLCOL3A.44
! Cloud Geometry CLCOL3A.45
& , N_CLOUD_TOP CLCOL3A.46
& , N_CLOUD_TYPE, FRAC_CLOUD CLCOL3A.47
& , N_COLUMN, L_COLUMN, AREA_COLUMN CLCOL3A.48
! Cloudy Optical Properties CLCOL3A.49
& , TAU_CLOUD, OMEGA_CLOUD, ASYMMETRY_CLOUD CLCOL3A.50
! Fluxes Calculated CLCOL3A.51
& , FLUX_DIRECT, FLUX_TOTAL CLCOL3A.52
! Flags for Clear-sky Calculations CLCOL3A.53
& , L_CLEAR, I_SOLVER_CLEAR CLCOL3A.54
! Clear-sky Fluxes Calculated CLCOL3A.55
& , FLUX_DIRECT_CLEAR, FLUX_TOTAL_CLEAR CLCOL3A.56
! Dimensions of Arrays CLCOL3A.57
& , NPD_PROFILE, NPD_LAYER, NPD_COLUMN CLCOL3A.58
& ) CLCOL3A.59
! CLCOL3A.60
! CLCOL3A.61
IMPLICIT NONE CLCOL3A.62
! CLCOL3A.63
! CLCOL3A.64
! SIZES OF DUMMY ARRAYS. CLCOL3A.65
INTEGER !, INTENT(IN) CLCOL3A.66
& NPD_PROFILE CLCOL3A.67
! MAXIMUM NUMBER OF PROFILES CLCOL3A.68
& , NPD_LAYER CLCOL3A.69
! MAXIMUM NUMBER OF LAYERS CLCOL3A.70
& , NPD_COLUMN CLCOL3A.71
! NUMBER OF COLUMNS PER POINT CLCOL3A.72
! CLCOL3A.73
! INCLUDE COMDECKS CLCOL3A.74
*CALL DIMFIX3A 
CLCOL3A.75
*CALL STDIO3A CLCOL3A.76
*CALL SPCRG3A CLCOL3A.77
*CALL SOLVER3A CLCOL3A.78
*CALL ERROR3A CLCOL3A.79
! CLCOL3A.80
! CLCOL3A.81
! DUMMY ARGUMENTS. CLCOL3A.82
INTEGER !, INTENT(OUT) CLCOL3A.83
& IERR CLCOL3A.84
! ERROR FLAG CLCOL3A.85
INTEGER !, INTENT(IN) CLCOL3A.86
& N_PROFILE CLCOL3A.87
! NUMBER OF PROFILES CLCOL3A.88
& , N_LAYER CLCOL3A.89
! NUMBER OF LAYERS CLCOL3A.90
INTEGER !, INTENT(IN) CLCOL3A.91
& ISOLIR CLCOL3A.92
! SPECTRAL REGION CLCOL3A.93
INTEGER !, INTENT(IN) CLCOL3A.94
& I_2STREAM CLCOL3A.95
! TWO STREAM SCHEME CLCOL3A.96
& , I_SOLVER CLCOL3A.97
! SOLVER FOR TWO-STREAM EQUATIONS ADB1F401.16
& , N_AUGMENT CLCOL3A.99
! LENGTH OF LONG VECTOR CLCOL3A.100
& , I_SOLVER_CLEAR CLCOL3A.101
! SOLVER FOR CLEAR FLUXES CLCOL3A.102
LOGICAL !, INTENT(IN) CLCOL3A.103
& L_CLEAR CLCOL3A.104
! CALCULATE CLEAR-SKY FLUXES CLCOL3A.105
& , L_SCALE_SOLAR CLCOL3A.106
! SCALE SOLAR BEAM CLCOL3A.107
& , L_IR_SOURCE_QUAD CLCOL3A.108
! USE A QUADRATIC SOURCE TERM CLCOL3A.109
& , L_2_STREAM_CORRECT CLCOL3A.110
! EDGE CORRECTION TO 2-STREAM CLCOL3A.111
! CLCOL3A.112
! FIELDS FOR EQUIVALENT EXTINCTION CLCOL3A.113
REAL !, INTENT(IN) CLCOL3A.114
& ADJUST_SOLAR_KE(NPD_PROFILE, NPD_LAYER) CLCOL3A.115
! ADJUSTMENT OF SOLAR BEAM WITH EQUIVALENT EXTINCTION CLCOL3A.116
! CLCOL3A.117
! CLEAR-SKY OPTICAL PROPETIES CLCOL3A.118
REAL !, INTENT(IN) CLCOL3A.119
& TAU_FREE(NPD_PROFILE, NPD_LAYER) CLCOL3A.120
! FREE OPTICAL DEPTH CLCOL3A.121
& , OMEGA_FREE(NPD_PROFILE, NPD_LAYER) CLCOL3A.122
! FREE ALBEDO OF SINGLE SCATTERING CLCOL3A.123
& , ASYMMETRY_FREE(NPD_PROFILE, NPD_LAYER) CLCOL3A.124
! FREE FRACTIONAL FORWARD SCATTER CLCOL3A.125
! CLCOL3A.126
! CLOUDY OPTICAL PROPETIES CLCOL3A.127
REAL !, INTENT(IN) CLCOL3A.128
& TAU_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) CLCOL3A.129
! OPTICAL DEPTH IN CLOUD CLCOL3A.130
& , ASYMMETRY_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) CLCOL3A.131
! CLOUDY FRACTIONAL FORWARD SCATTER CLCOL3A.132
& , OMEGA_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) CLCOL3A.133
! ALBEDO OF SINGLE SCATTERING IN CLOUD CLCOL3A.134
! CLCOL3A.135
! PLANCKIAN TERMS: CLCOL3A.136
REAL !, INTENT(IN) CLCOL3A.137
& DIFF_PLANCK(NPD_PROFILE, NPD_LAYER) CLCOL3A.138
! CHANGE IN PLANCK FUNCTION CLCOL3A.139
& , DIFF_PLANCK_2(NPD_PROFILE, NPD_LAYER) CLCOL3A.140
! TWICE 2ND DIFFERENCES IN PLANCKIAN CLCOL3A.141
& , PLANCK_SOURCE(NPD_PROFILE, 0: NPD_LAYER) CLCOL3A.142
! PLANCKIAN SOURCE FUNCTION CLCOL3A.143
! CLCOL3A.144
! CONDITIONS AT TOA CLCOL3A.145
REAL !, INTENT(IN) CLCOL3A.146
& SEC_0(NPD_PROFILE) CLCOL3A.147
! SECANT OF ZENITH ANGLE CLCOL3A.148
& , FLUX_INC_DIRECT(NPD_PROFILE) CLCOL3A.149
! INCIDENT DIRECT FLUX CLCOL3A.150
& , FLUX_INC_DOWN(NPD_PROFILE) CLCOL3A.151
! INCIDENT TOTAL FLUX CLCOL3A.152
! CLCOL3A.153
! CONDITIONS AT SURFACE CLCOL3A.154
REAL !, INTENT(IN) CLCOL3A.155
& ALBEDO_SURFACE_DIFF(NPD_PROFILE) CLCOL3A.156
! DIFFUSE ALBEDO OF GROUND CLCOL3A.157
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) CLCOL3A.158
! DIRECT ALBEDO OF GROUND CLCOL3A.159
& , SOURCE_GROUND(NPD_PROFILE) CLCOL3A.160
! SOURCE FUNCTION OF GROUND CLCOL3A.161
! CLCOL3A.162
! CLOUD GEOMETRY CLCOL3A.163
INTEGER !, INTENT(IN) CLCOL3A.164
& N_CLOUD_TOP CLCOL3A.165
! TOP CLOUDY LAYER CLCOL3A.166
& , N_CLOUD_TYPE CLCOL3A.167
! NUMBER OF TYPES OF CLOUDS CLCOL3A.168
& , N_COLUMN(NPD_PROFILE) CLCOL3A.169
! NUMBER OF COLUMNS CLCOL3A.170
LOGICAL !, INTENT(IN) CLCOL3A.171
& L_COLUMN(NPD_PROFILE, NPD_LAYER, NPD_COLUMN) CLCOL3A.172
! TYPE FLAG FOR EACH LAYER/COLUMN CLCOL3A.173
REAL !, INTENT(IN) CLCOL3A.174
& FRAC_CLOUD(NPD_PROFILE, NPD_COLUMN, NPD_CLOUD_TYPE) CLCOL3A.175
! AREA OF EACH COLUMN CLCOL3A.176
& , AREA_COLUMN(NPD_PROFILE, NPD_COLUMN) CLCOL3A.177
! AREA OF EACH COLUMN CLCOL3A.178
! CLCOL3A.179
REAL !, INTENT(IN) CLCOL3A.180
& GROUND_EMISSION(NPD_PROFILE) CLCOL3A.181
! TOTAL FLUX EMITTED FROM GROUND CLCOL3A.182
! CLCOL3A.183
! FLUXES CALCULATED: CLCOL3A.184
REAL !, INTENT(OUT) CLCOL3A.185
& FLUX_DIRECT(NPD_PROFILE, 0: NPD_LAYER) CLCOL3A.186
! DIRECT FLUX CLCOL3A.187
& , FLUX_TOTAL(NPD_PROFILE, 2*NPD_LAYER+2) CLCOL3A.188
! TOTAL FLUX CLCOL3A.189
& , FLUX_DIRECT_CLEAR(NPD_PROFILE, 0: NPD_LAYER) CLCOL3A.190
! CLEAR DIRECT FLUX CLCOL3A.191
& , FLUX_TOTAL_CLEAR(NPD_PROFILE, 2*NPD_LAYER+2) CLCOL3A.192
! CLEAR TOTAL FLUX CLCOL3A.193
! CLCOL3A.194
! CLCOL3A.195
! CLCOL3A.196
! LOCAL VARIABLES. CLCOL3A.197
INTEGER CLCOL3A.198
& N_SOURCE_COEFF CLCOL3A.199
! NUMBER OF SOURCE COEFFICIENTS CLCOL3A.200
& , N_EQUATION CLCOL3A.201
! NUMBER OF EQUATIONS SOLVED CLCOL3A.202
& , I CLCOL3A.203
! LOOP VARIABLE CLCOL3A.204
& , J CLCOL3A.205
! LOOP VARIABLE CLCOL3A.206
& , JS CLCOL3A.207
! LOOP VARIABLE CLCOL3A.208
& , L CLCOL3A.209
! LOOP VARIABLE CLCOL3A.210
& , K CLCOL3A.211
! LOOP VARIABLE CLCOL3A.212
INTEGER CLCOL3A.213
& N_LONG CLCOL3A.214
! LENGTH OF LONG VECTOR CLCOL3A.215
& , N_PROFILE_SOLVED CLCOL3A.216
! NUMBER OF PROFILES SOLVED AT ONCE CLCOL3A.217
& , N_COLUMN_DONE CLCOL3A.218
! NUMBER OF COLUMNS ALREADY ASSIGNED CLCOL3A.219
& , OFFSET CLCOL3A.220
! OFFSET IN LIST OF PROFILES CLCOL3A.221
& , I_PROFILE CLCOL3A.222
! PROFILE BEING CONSIDERED CLCOL3A.223
! CLCOL3A.224
REAL CLCOL3A.225
& SOURCE_COEFF_FREE(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) CLCOL3A.226
! FREE SOURCE COEFFICIENTS CLCOL3A.227
& , TRANS_FREE(NPD_PROFILE, NPD_LAYER) CLCOL3A.228
! FREE DIFFUSE TRANSMISSION CLCOL3A.229
& , TRANS_0_FREE(NPD_PROFILE, NPD_LAYER) CLCOL3A.230
! FREE DIRECT TRANSMISSION CLCOL3A.231
& , REFLECT_FREE(NPD_PROFILE, NPD_LAYER) CLCOL3A.232
! FREE REFLECTANCE CLCOL3A.233
& , S_DOWN_FREE(NPD_PROFILE, NPD_LAYER) CLCOL3A.234
! FREE DOWNWARD SOURCE CLCOL3A.235
& , S_UP_FREE(NPD_PROFILE, NPD_LAYER) CLCOL3A.236
! FREE UPWARD SOURCE CLCOL3A.237
! CLCOL3A.238
REAL CLCOL3A.239
& SOURCE_COEFF_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) CLCOL3A.240
! CLOUDY TWO-STREAM SOURCE COEFFICIENTS CLCOL3A.241
& , TRANS_CLOUD(NPD_PROFILE, NPD_LAYER) CLCOL3A.242
! CLOUDY DIFFUSE TRANSMISSION CLCOL3A.243
& , REFLECT_CLOUD(NPD_PROFILE, NPD_LAYER) CLCOL3A.244
! CLOUDY REFLECTANCE CLCOL3A.245
& , TRANS_0_CLOUD(NPD_PROFILE, NPD_LAYER) CLCOL3A.246
! CLOUDY DIRECT TRANSMISSION CLCOL3A.247
& , S_DOWN_CLOUD(NPD_PROFILE, NPD_LAYER) CLCOL3A.248
! CLOUDY DOWNWARD SOURCE CLCOL3A.249
& , S_UP_CLOUD(NPD_PROFILE, NPD_LAYER) CLCOL3A.250
! CLOUDY UPWARD SOURCE CLCOL3A.251
! CLCOL3A.252
REAL CLCOL3A.253
& FLUX_LONG(NPD_PROFILE, 2*NPD_LAYER+2) CLCOL3A.254
! DIFFUSE FLUXES IN COLUMNS CLCOL3A.255
& , FLUX_DIRECT_LONG(NPD_PROFILE, 0: NPD_LAYER) CLCOL3A.256
! DIRECT FLUXES IN COLUMNS CLCOL3A.257
! CLCOL3A.258
REAL CLCOL3A.259
& SOURCE_GROUND_LONG(NPD_PROFILE) CLCOL3A.260
! SOURCE FUNCTION OF GROUND IN COL. CLCOL3A.261
& , FLUX_INC_DIRECT_LONG(NPD_PROFILE) CLCOL3A.262
! DIRECT FLUX INCIDENT ON COLUMN CLCOL3A.263
& , FLUX_INC_DOWN_LONG(NPD_PROFILE) CLCOL3A.264
! DIRECT FLUX INCIDENT ON COLUMN CLCOL3A.265
& , ALBEDO_SURFACE_DIFF_LONG(NPD_PROFILE) CLCOL3A.266
! DIFFUSE ALBEDO OF GROUND CLCOL3A.267
& , ALBEDO_SURFACE_DIR_LONG(NPD_PROFILE) CLCOL3A.268
! DIRECT ALBEDO OF GROUND CLCOL3A.269
& , TRANS_LONG(NPD_PROFILE, NPD_LAYER) CLCOL3A.270
! TRANSMISSION IN LONG ARRAY CLCOL3A.271
& , REFLECT_LONG(NPD_PROFILE, NPD_LAYER) CLCOL3A.272
! REFLECTION IN LONG ARRAY CLCOL3A.273
& , TRANS_0_LONG(NPD_PROFILE, NPD_LAYER) CLCOL3A.274
! SOLAR COEFFICIENT IN LONG ARRAY CLCOL3A.275
& , SOURCE_COEFF_LONG(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) CLCOL3A.276
! SOURCE COEFFICIENTS IN LONG ARRAY CLCOL3A.277
& , S_UP_LONG(NPD_PROFILE, NPD_LAYER) CLCOL3A.278
! UPWARD SOURCE FUNCTION CLCOL3A.279
& , S_DOWN_LONG(NPD_PROFILE, NPD_LAYER) CLCOL3A.280
! DOWNWARD SOURCE FUNCTION CLCOL3A.281
& , SCALE_SOLAR_LONG(NPD_PROFILE, NPD_LAYER) CLCOL3A.282
! LONG VECTOR OF SOLAR SCALINGS CLCOL3A.283
& , WORK_1(NPD_PROFILE, 2*NPD_LAYER+2) CLCOL3A.284
! WORK ARRAY CLCOL3A.285
& , WORK_2(NPD_PROFILE, 2*NPD_LAYER+2) CLCOL3A.286
! WORK ARRAY CLCOL3A.287
! CLCOL3A.288
REAL CLCOL3A.289
& A3(NPD_PROFILE, 3, 2*NPD_LAYER+2) CLCOL3A.290
! TRIDIAGONAL MATRIX CLCOL3A.291
& , A5(NPD_PROFILE, 5, 2*NPD_LAYER+2) CLCOL3A.292
! PENTADIAGONAL MATRIX CLCOL3A.293
& , B(NPD_PROFILE, 2*NPD_LAYER+2) CLCOL3A.294
! RIGHT-HAND SIDES OF EQUATIONS CLCOL3A.295
! CLCOL3A.296
! CLCOL3A.297
! FUNCTIONS CALLED: CLCOL3A.298
INTEGER CLCOL3A.299
& SET_N_SOURCE_COEFF CLCOL3A.300
! FUNCTION TO SET NUMBER OF SOURCE COEFFICIENTS CLCOL3A.301
! CLCOL3A.302
! SUBROUTINES CALLED: CLCOL3A.303
EXTERNAL CLCOL3A.304
& TWO_COEFF, TWO_COEFF_CLOUD, IR_SOURCE, SOLAR_SOURCE CLCOL3A.305
*IF DEF,SCMA AJC0F405.297
& , SET_MATRIX_FULL AJC0F405.298
*ELSE AJC0F405.299
& , SET_MATRIX_NET, TRIDIAG_SOLVER_UP, SET_MATRIX_FULL AJC0F405.300
*ENDIF AJC0F405.301
& , SET_MATRIX_PENTADIAGONAL, BAND_SOLVER CLCOL3A.307
& , SOLVER_HOMOGEN_DIRECT, CLEAR_SUPPLEMENT ADB1F401.17
! CLCOL3A.309
! CLCOL3A.310
! CLCOL3A.311
! CLCOL3A.312
! ENTER A SUMMING LOOP TO CALCULATE THE TOTAL FLUX BY ADDING UP ADB1F401.18
! THE FLOW OF ENERGY IN EACH COLUMN. CLCOL3A.314
! CLCOL3A.315
IF (ISOLIR.EQ.IP_SOLAR) THEN CLCOL3A.316
DO I=0, N_LAYER CLCOL3A.317
DO L=1, N_PROFILE CLCOL3A.318
FLUX_DIRECT(L, I)=0.0E+00 CLCOL3A.319
ENDDO CLCOL3A.320
ENDDO CLCOL3A.321
ENDIF CLCOL3A.322
DO I=1, N_AUGMENT CLCOL3A.323
DO L=1, N_PROFILE CLCOL3A.324
FLUX_TOTAL(L, I)=0.0E+00 CLCOL3A.325
ENDDO CLCOL3A.326
ENDDO CLCOL3A.327
! CLCOL3A.328
! SET THE NUMBER OF SOURCE COEFFICIENTS FOR THE APPROXIMATION CLCOL3A.329
N_SOURCE_COEFF=SET_N_SOURCE_COEFF(ISOLIR, L_IR_SOURCE_QUAD) CLCOL3A.330
! CLCOL3A.331
! THE FUNDAMENTAL PARAMETERS OF THE TWO-STREAM EQUATIONS CAN BE CLCOL3A.332
! PRECALCULATED. CLCOL3A.333
CALL TWO_COEFF(IERR CLCOL3A.334
& , N_PROFILE, 1, N_LAYER CLCOL3A.335
& , I_2STREAM, L_IR_SOURCE_QUAD CLCOL3A.336
& , ASYMMETRY_FREE, OMEGA_FREE, TAU_FREE CLCOL3A.337
& , ISOLIR, SEC_0 CLCOL3A.338
& , TRANS_FREE, REFLECT_FREE, TRANS_0_FREE CLCOL3A.339
& , SOURCE_COEFF_FREE CLCOL3A.340
& , NPD_PROFILE, NPD_LAYER CLCOL3A.341
& ) CLCOL3A.342
IF (IERR.NE.I_NORMAL) RETURN CLCOL3A.343
! CLCOL3A.344
CALL TWO_COEFF_CLOUD(IERR CLCOL3A.345
& , N_PROFILE, N_CLOUD_TOP, N_LAYER CLCOL3A.346
& , I_2STREAM, L_IR_SOURCE_QUAD, N_SOURCE_COEFF CLCOL3A.347
& , N_CLOUD_TYPE, FRAC_CLOUD CLCOL3A.348
& , ASYMMETRY_CLOUD, OMEGA_CLOUD, TAU_CLOUD CLCOL3A.349
& , ISOLIR, SEC_0 CLCOL3A.350
& , TRANS_CLOUD, REFLECT_CLOUD, TRANS_0_CLOUD CLCOL3A.351
& , SOURCE_COEFF_CLOUD CLCOL3A.352
& , NPD_PROFILE, NPD_LAYER CLCOL3A.353
& ) CLCOL3A.354
IF (IERR.NE.I_NORMAL) RETURN CLCOL3A.355
! CLCOL3A.356
! CLCOL3A.357
! THE INFRA-RED SOURCE FUNCTIONS DEPEND ONLY ON THE LAYER IN WHICH CLCOL3A.358
! THEY ARE EVALUATED AND, UNLIKE THE VISIBLE SOURCE FUNCTIONS, THEY CLCOL3A.359
! MAY BE PRECALCULATED. CLCOL3A.360
IF (ISOLIR.EQ.IP_INFRA_RED) THEN CLCOL3A.361
CALL IR_SOURCE(N_PROFILE, 1, N_LAYER CLCOL3A.362
& , SOURCE_COEFF_FREE, DIFF_PLANCK CLCOL3A.363
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_2 CLCOL3A.364
& , L_2_STREAM_CORRECT, PLANCK_SOURCE CLCOL3A.365
& , GROUND_EMISSION, N_LAYER CLCOL3A.366
& , TAU_FREE, TRANS_FREE CLCOL3A.367
& , S_DOWN_FREE, S_UP_FREE CLCOL3A.368
& , NPD_PROFILE, NPD_LAYER CLCOL3A.369
& ) CLCOL3A.370
CALL IR_SOURCE(N_PROFILE, N_CLOUD_TOP, N_LAYER CLCOL3A.371
& , SOURCE_COEFF_CLOUD, DIFF_PLANCK CLCOL3A.372
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_2 CLCOL3A.373
& , L_2_STREAM_CORRECT, PLANCK_SOURCE CLCOL3A.374
& , GROUND_EMISSION, N_LAYER CLCOL3A.375
& , TAU_CLOUD, TRANS_CLOUD CLCOL3A.376
& , S_DOWN_CLOUD, S_UP_CLOUD CLCOL3A.377
& , NPD_PROFILE, NPD_LAYER CLCOL3A.378
& ) CLCOL3A.379
ENDIF CLCOL3A.380
! CLCOL3A.381
! CLCOL3A.382
! THE MAIN LOOP: PROFILES ARE ADDED ON TO THE LONG ARRAY UNTIL CLCOL3A.383
! IT IS NO LONGER POSSIBLE TO SOLVE FOR THEM ALL IN ONE GO. CLCOL3A.384
OFFSET=0 CLCOL3A.385
N_LONG=0 CLCOL3A.386
I_PROFILE=1 CLCOL3A.387
! CLCOL3A.388
10 IF (N_LONG+N_COLUMN(I_PROFILE).LE.NPD_PROFILE) THEN CLCOL3A.389
! CONTINUE FEEDING PROFILES INTO THE LONG ARRAY: CLCOL3A.390
! CLCOL3A.391
DO J=1, N_COLUMN(I_PROFILE) CLCOL3A.392
! CLCOL3A.393
! ASSIGN THE OPTICAL PROPERTIES TO EACH LAYER WITHIN THE CLCOL3A.394
! COLUMN. J IS THE INDEX OF COLUMNS AT A GRID-POINT: CLCOL3A.395
! K INDEXES POINTS IN THE LONG VECTOR. CLCOL3A.396
K=N_LONG+J CLCOL3A.397
! CLCOL3A.398
DO I=1, N_LAYER CLCOL3A.399
IF (L_COLUMN(I_PROFILE, I, J)) THEN CLCOL3A.400
! THE LAYER IS CLOUDY. CLCOL3A.401
TRANS_LONG(K, I)=TRANS_CLOUD(I_PROFILE, I) CLCOL3A.402
REFLECT_LONG(K, I)=REFLECT_CLOUD(I_PROFILE, I) CLCOL3A.403
ELSE CLCOL3A.404
! THE LAYER IS FREE OF CLOUD. CLCOL3A.405
TRANS_LONG(K, I)=TRANS_FREE(I_PROFILE, I) CLCOL3A.406
REFLECT_LONG(K, I)=REFLECT_FREE(I_PROFILE, I) CLCOL3A.407
ENDIF CLCOL3A.408
ENDDO CLCOL3A.409
IF (ISOLIR.EQ.IP_SOLAR) THEN CLCOL3A.410
FLUX_INC_DIRECT_LONG(K)=FLUX_INC_DIRECT(I_PROFILE) CLCOL3A.411
SOURCE_GROUND_LONG(K)=0.0E+00 CLCOL3A.412
DO I=1, N_LAYER CLCOL3A.413
IF (L_COLUMN(I_PROFILE, I, J)) THEN CLCOL3A.414
TRANS_0_LONG(K, I) CLCOL3A.415
& =TRANS_0_CLOUD(I_PROFILE, I) CLCOL3A.416
DO JS=1, N_SOURCE_COEFF CLCOL3A.417
SOURCE_COEFF_LONG(K, I, JS) CLCOL3A.418
& =SOURCE_COEFF_CLOUD(I_PROFILE, I, JS) CLCOL3A.419
ENDDO CLCOL3A.420
ELSE CLCOL3A.421
TRANS_0_LONG(K, I)=TRANS_0_FREE(I_PROFILE, I) CLCOL3A.422
DO JS=1, N_SOURCE_COEFF CLCOL3A.423
SOURCE_COEFF_LONG(K, I, JS) CLCOL3A.424
& =SOURCE_COEFF_FREE(I_PROFILE, I, JS) CLCOL3A.425
ENDDO CLCOL3A.426
ENDIF CLCOL3A.427
ENDDO CLCOL3A.428
IF (L_SCALE_SOLAR) THEN CLCOL3A.429
DO I=1, N_LAYER CLCOL3A.430
SCALE_SOLAR_LONG(K, I) CLCOL3A.431
& =ADJUST_SOLAR_KE(I_PROFILE, I) CLCOL3A.432
ENDDO CLCOL3A.433
ENDIF CLCOL3A.434
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN CLCOL3A.435
DO I=1, N_LAYER CLCOL3A.436
IF (L_COLUMN(I_PROFILE, I, J)) THEN CLCOL3A.437
S_UP_LONG(K, I)=S_UP_CLOUD(I_PROFILE, I) CLCOL3A.438
S_DOWN_LONG(K, I)=S_DOWN_CLOUD(I_PROFILE, I) CLCOL3A.439
ELSE CLCOL3A.440
S_DOWN_LONG(K, I)=S_DOWN_FREE(I_PROFILE, I) CLCOL3A.441
S_UP_LONG(K, I)=S_UP_FREE(I_PROFILE, I) CLCOL3A.442
ENDIF CLCOL3A.443
ENDDO CLCOL3A.444
SOURCE_GROUND_LONG(K)=SOURCE_GROUND(I_PROFILE) CLCOL3A.445
ENDIF CLCOL3A.446
FLUX_INC_DOWN_LONG(K)=FLUX_INC_DOWN(I_PROFILE) CLCOL3A.447
ALBEDO_SURFACE_DIFF_LONG(K) CLCOL3A.448
& =ALBEDO_SURFACE_DIFF(I_PROFILE) CLCOL3A.449
ALBEDO_SURFACE_DIR_LONG(K) CLCOL3A.450
& =ALBEDO_SURFACE_DIR(I_PROFILE) CLCOL3A.451
ENDDO CLCOL3A.452
! CLCOL3A.453
N_LONG=N_LONG+N_COLUMN(I_PROFILE) CLCOL3A.454
! CLCOL3A.455
! INCREMENT I_PROFILE AND RETURN TO SEE IF ANOTHER PROFILE CLCOL3A.456
! MAY BE ADDED. CLCOL3A.457
IF (I_PROFILE.LT.N_PROFILE) THEN CLCOL3A.458
I_PROFILE=I_PROFILE+1 CLCOL3A.459
GOTO 10 CLCOL3A.460
ENDIF CLCOL3A.461
! CLCOL3A.462
ELSE IF (N_COLUMN(I_PROFILE).GT.NPD_PROFILE) THEN CLCOL3A.463
WRITE(IU_ERR, '(/A, I5, A, /A)') CLCOL3A.464
& '*** ERROR: PROFILE ', I_PROFILE CLCOL3A.465
& , ' CONTAINS TOO MANY COLUMNS.' CLCOL3A.466
& , 'INCREASE NPD_PROFILE AND RECOMPILE.' CLCOL3A.467
ELSE CLCOL3A.468
! IF NO MORE PROFILES CAN BE ADDED THE EQUATIONS ARE SOLVED. CLCOL3A.469
! RESET THE POINTER TO POINT TO THE LAST PROFILE CONSIDERED. CLCOL3A.470
I_PROFILE=I_PROFILE-1 CLCOL3A.471
ENDIF CLCOL3A.472
! CLCOL3A.473
N_PROFILE_SOLVED=I_PROFILE-OFFSET CLCOL3A.474
! CLCOL3A.475
IF (ISOLIR.EQ.IP_SOLAR) THEN CLCOL3A.476
CALL SOLAR_SOURCE(N_LONG, N_LAYER CLCOL3A.477
& , FLUX_INC_DIRECT_LONG CLCOL3A.478
& , TRANS_0_LONG, SOURCE_COEFF_LONG CLCOL3A.479
& , L_SCALE_SOLAR, SCALE_SOLAR_LONG CLCOL3A.480
& , FLUX_DIRECT_LONG CLCOL3A.481
& , S_DOWN_LONG, S_UP_LONG CLCOL3A.482
& , NPD_PROFILE, NPD_LAYER CLCOL3A.483
& ) CLCOL3A.484
ELSE ADB2F404.6
! SET THE DIRECT FLUX AT THE GROUND FOR USE IN THE SOLVER. ADB2F404.7
DO K=1, N_LONG ADB2F404.8
FLUX_DIRECT_LONG(K, N_LAYER)=0.0E+00 ADB2F404.9
ENDDO ADB2F404.10
ENDIF CLCOL3A.485
! CLCOL3A.486
! CLCOL3A.497
! SELECT AN APPROPRIATE SOLVER FOR THE EQUATIONS. ADB1F405.5
! CLCOL3A.516
IF (I_SOLVER.EQ.IP_SOLVER_PENTADIAGONAL) THEN ADB1F405.6
! CLCOL3A.527
CALL SET_MATRIX_PENTADIAGONAL(N_LONG, N_LAYER CLCOL3A.528
& , TRANS_LONG, REFLECT_LONG CLCOL3A.529
& , S_DOWN_LONG, S_UP_LONG CLCOL3A.530
& , ALBEDO_SURFACE_DIFF_LONG, ALBEDO_SURFACE_DIR_LONG CLCOL3A.531
& , FLUX_DIRECT_LONG(1, N_LAYER), FLUX_INC_DOWN_LONG CLCOL3A.532
& , SOURCE_GROUND_LONG CLCOL3A.533
& , A5, B CLCOL3A.534
& , NPD_PROFILE, NPD_LAYER CLCOL3A.535
& ) CLCOL3A.536
N_EQUATION=2*N_LAYER+2 CLCOL3A.537
! CLCOL3A.538
CALL BAND_SOLVER(N_LONG, N_EQUATION CLCOL3A.539
& , 2, 2 CLCOL3A.540
& , A5, B CLCOL3A.541
& , FLUX_LONG CLCOL3A.542
& , NPD_PROFILE, 2*NPD_LAYER+2 CLCOL3A.543
& , WORK_1 CLCOL3A.544
& ) ADB1F401.19
! ADB1F401.20
ELSE IF (I_SOLVER.EQ.IP_SOLVER_HOMOGEN_DIRECT) THEN ADB1F401.21
! ADB1F401.22
CALL SOLVER_HOMOGEN_DIRECT(N_LONG, N_LAYER ADB1F401.23
& , TRANS_LONG, REFLECT_LONG ADB1F401.24
& , S_DOWN_LONG, S_UP_LONG ADB1F401.25
& , ALBEDO_SURFACE_DIFF_LONG, ALBEDO_SURFACE_DIR_LONG ADB1F401.26
& , FLUX_DIRECT_LONG(1, N_LAYER), FLUX_INC_DOWN_LONG ADB1F401.27
& , SOURCE_GROUND_LONG ADB1F401.28
& , FLUX_LONG ADB1F401.29
& , NPD_PROFILE, NPD_LAYER ADB1F401.30
& ) CLCOL3A.545
! CLCOL3A.546
ELSE CLCOL3A.547
! CLCOL3A.548
WRITE(IU_ERR, '(/A)') CLCOL3A.549
& '*** ERROR: THE SOLVER AND CLOUD SCHEME ' CLCOL3A.550
& //'ARE NOT COMPATIBLE.' CLCOL3A.551
IERR=I_ERR_FATAL CLCOL3A.552
RETURN CLCOL3A.553
! CLCOL3A.554
ENDIF CLCOL3A.555
! CLCOL3A.556
! CLCOL3A.557
! ADD THE PARTIAL FLUX FOR THE COLUMN ONTO THE CUMULATIVE TOTAL. CLCOL3A.558
! CLCOL3A.559
N_COLUMN_DONE=0 CLCOL3A.560
DO L=OFFSET+1, N_PROFILE_SOLVED+OFFSET CLCOL3A.561
DO J=1, N_COLUMN(L) CLCOL3A.562
K=J+N_COLUMN_DONE CLCOL3A.563
IF (ISOLIR.EQ.IP_SOLAR) THEN CLCOL3A.564
DO I=0, N_LAYER CLCOL3A.565
FLUX_DIRECT(L, I)=FLUX_DIRECT(L, I) CLCOL3A.566
& +FLUX_DIRECT_LONG(K, I)*AREA_COLUMN(L, J) CLCOL3A.567
ENDDO CLCOL3A.568
ENDIF CLCOL3A.569
DO I=1, N_AUGMENT CLCOL3A.570
FLUX_TOTAL(L, I)=FLUX_TOTAL(L, I) CLCOL3A.571
& +FLUX_LONG(K, I)*AREA_COLUMN(L, J) CLCOL3A.572
ENDDO CLCOL3A.573
ENDDO CLCOL3A.574
N_COLUMN_DONE=N_COLUMN_DONE+N_COLUMN(L) CLCOL3A.575
ENDDO CLCOL3A.576
! CLCOL3A.577
! THE OFFSET IS NOW ADVANCED FOR THE NEXT LOOP AND A NEW CLCOL3A.578
! LONG VECTOR IS FORMED UNLESS WE HAVE ALREADY SOLVED FOR ALL CLCOL3A.579
! THE PROFILES. CLCOL3A.580
OFFSET=OFFSET+N_PROFILE_SOLVED CLCOL3A.581
IF (OFFSET.LT.N_PROFILE) THEN CLCOL3A.582
N_LONG=0 CLCOL3A.583
I_PROFILE=I_PROFILE+1 ADB2F404.11
GOTO 10 CLCOL3A.584
ENDIF CLCOL3A.585
! CLCOL3A.586
! CLCOL3A.587
! CLCOL3A.588
IF (L_CLEAR) THEN CLCOL3A.589
CALL CLEAR_SUPPLEMENT(IERR, N_PROFILE, N_LAYER, I_SOLVER_CLEAR CLCOL3A.590
& , TRANS_FREE, REFLECT_FREE, TRANS_0_FREE, SOURCE_COEFF_FREE CLCOL3A.591
& , ISOLIR, FLUX_INC_DIRECT, FLUX_INC_DOWN CLCOL3A.592
& , S_DOWN_FREE, S_UP_FREE CLCOL3A.593
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR CLCOL3A.594
& , SOURCE_GROUND CLCOL3A.595
& , L_SCALE_SOLAR, ADJUST_SOLAR_KE CLCOL3A.596
& , FLUX_DIRECT_CLEAR, FLUX_TOTAL_CLEAR CLCOL3A.597
& , NPD_PROFILE, NPD_LAYER CLCOL3A.598
& ) CLCOL3A.599
ENDIF CLCOL3A.600
! CLCOL3A.601
! CLCOL3A.602
RETURN CLCOL3A.603
END CLCOL3A.604
*ENDIF DEF,A01_3A,OR,DEF,A02_3A CLCOL3A.605
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.12