SUBROUTINE TWO_STREAM(IERR 1,6TSTR3A.23
! Atmospheric Properties TSTR3A.24
& , N_PROFILE, N_LAYER TSTR3A.25
! Two-stream Scheme TSTR3A.26
& , I_2STREAM TSTR3A.27
! Corrections to Two-stream scheme TSTR3A.28
& , L_2_STREAM_CORRECT, PLANCK_SOURCE, GROUND_EMISSION TSTR3A.29
! Options for Solver TSTR3A.30
& , L_NET, I_SOLVER TSTR3A.31
! Options for Equivalent Extinction TSTR3A.32
& , L_SCALE_SOLAR, ADJUST_SOLAR_KE TSTR3A.33
! Spectral Region TSTR3A.34
& , ISOLIR TSTR3A.35
! Infra-red Properties TSTR3A.36
& , DIFF_PLANCK TSTR3A.37
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_2 TSTR3A.38
! Conditions at TOA TSTR3A.39
& , FLUX_INC_DOWN, FLUX_INC_DIRECT, SEC_0 TSTR3A.40
! Surface Conditions TSTR3A.41
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR, SOURCE_GROUND TSTR3A.42
! Single Scattering Properties TSTR3A.43
& , TAU, OMEGA, ASYMMETRY TSTR3A.44
! Fluxes Calculated TSTR3A.45
& , FLUX_DIRECT, FLUX_TOTAL TSTR3A.46
! Flag for Clear-sky Fluxes TSTR3A.47
& , L_CLEAR TSTR3A.48
! Clear-sky Fluxes Calculated TSTR3A.49
& , FLUX_DIRECT_CLEAR, FLUX_TOTAL_CLEAR TSTR3A.50
& , NPD_PROFILE, NPD_LAYER TSTR3A.51
& ) TSTR3A.52
! TSTR3A.53
! TSTR3A.54
! TSTR3A.55
IMPLICIT NONE TSTR3A.56
! TSTR3A.57
! TSTR3A.58
! SIZES OF DUMMY ARRAYS. TSTR3A.59
INTEGER !, INTENT(IN) TSTR3A.60
& NPD_PROFILE TSTR3A.61
! MAXIMUM NUMBER OF PROFILES TSTR3A.62
& , NPD_LAYER TSTR3A.63
! MAXIMUM NUMBER OF LAYERS TSTR3A.64
! INCLUDE COMDECKS. TSTR3A.65
*CALL DIMFIX3A 
TSTR3A.66
*CALL STDIO3A TSTR3A.67
*CALL ERROR3A TSTR3A.68
*CALL SOLVER3A TSTR3A.69
*CALL SPCRG3A TSTR3A.70
! TSTR3A.71
! DUMMY VARIABLES. TSTR3A.72
INTEGER !, INTENT(IN) TSTR3A.73
& N_PROFILE TSTR3A.74
! NUMBER OF PROFILES TSTR3A.75
& , N_LAYER TSTR3A.76
! NUMBER OF LAYERS TSTR3A.77
& , ISOLIR TSTR3A.78
! SPECTRAL REGION TSTR3A.79
& , I_SOLVER TSTR3A.80
! SOLVER EMPLOYED TSTR3A.81
& , I_2STREAM TSTR3A.82
! TWO-STREAM SCHEME TSTR3A.83
INTEGER !, INTENT(OUT) TSTR3A.84
& IERR TSTR3A.85
! ERROR FLAG TSTR3A.86
LOGICAL !, INTENT(IN) TSTR3A.87
& L_NET TSTR3A.88
! CALCULATE NET FLUXES TSTR3A.89
& , L_CLEAR TSTR3A.90
! CALCULATE CLEAR FLUXES TSTR3A.91
& , L_SCALE_SOLAR TSTR3A.92
! SCALING APPLIED TO SOLAR FLUX TSTR3A.93
& , L_IR_SOURCE_QUAD TSTR3A.94
! USE QUADRATIC SOURCE TERM TSTR3A.95
& , L_2_STREAM_CORRECT TSTR3A.96
! EDGE CORRECTION FOR 2-STREAM TSTR3A.97
REAL !, INTENT(IN) TSTR3A.98
& TAU(NPD_PROFILE, NPD_LAYER) TSTR3A.99
! OPTICAL DEPTH TSTR3A.100
& , OMEGA(NPD_PROFILE, NPD_LAYER) TSTR3A.101
! ALBEDO OF SINGLE SCATTERING TSTR3A.102
& , ASYMMETRY(NPD_PROFILE, NPD_LAYER) TSTR3A.103
! ASYMMETRY TSTR3A.104
& , SEC_0(NPD_PROFILE) TSTR3A.105
! SECANTS OF SOLAR ZENITH ANGLES TSTR3A.106
& , ALBEDO_SURFACE_DIFF(NPD_PROFILE) TSTR3A.107
! DIFFUSE ALBEDO TSTR3A.108
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) TSTR3A.109
! DIRECT ALBEDO TSTR3A.110
& , FLUX_INC_DOWN(NPD_PROFILE) TSTR3A.111
! INCIDENT TOTAL FLUX TSTR3A.112
& , FLUX_INC_DIRECT(NPD_PROFILE) TSTR3A.113
! INCIDENT DIRECT FLUX TSTR3A.114
& , DIFF_PLANCK(NPD_PROFILE, NPD_LAYER) TSTR3A.115
! DIFFERENCE IN PI*PLANCK FUNCTION TSTR3A.116
& , SOURCE_GROUND(NPD_PROFILE) TSTR3A.117
! GROUND SOURCE FUNCTION TSTR3A.118
& , ADJUST_SOLAR_KE(NPD_PROFILE, NPD_LAYER) TSTR3A.119
! ADJUSTMENT OF SOLAR BEAM WITH EQUIVALENT EXTINCTION TSTR3A.120
& , DIFF_PLANCK_2(NPD_PROFILE, NPD_LAYER) TSTR3A.121
! 2x2ND DIFFERENCES OF PLANCKIAN TSTR3A.122
& , PLANCK_SOURCE(NPD_PROFILE, NPD_LAYER) TSTR3A.123
! PLANCKIAN SOURCE FUNCTION TSTR3A.124
& , GROUND_EMISSION(NPD_PROFILE) TSTR3A.125
! TOTAL FLUX EMITTED FROM GROUND TSTR3A.126
REAL !, INTENT(OUT) TSTR3A.127
& FLUX_DIRECT(NPD_PROFILE, 0: NPD_LAYER) TSTR3A.128
! DIRECT FLUX TSTR3A.129
& , FLUX_TOTAL(NPD_PROFILE, 2*NPD_LAYER+2) TSTR3A.130
! TOTAL FLUXES TSTR3A.131
& , FLUX_DIRECT_CLEAR(NPD_PROFILE, 0: NPD_LAYER) TSTR3A.132
! CLEAR DIRECT FLUX TSTR3A.133
& , FLUX_TOTAL_CLEAR(NPD_PROFILE, 2*NPD_LAYER+2) TSTR3A.134
! CLEAR TOTAL FLUXES TSTR3A.135
! TSTR3A.136
! TSTR3A.137
! LOCAL VARIABALES. TSTR3A.138
INTEGER TSTR3A.139
& N_EQUATION TSTR3A.140
! NUMBER OF EQUATIONS TSTR3A.141
& , I TSTR3A.142
! LOOP VARIABLE TSTR3A.143
& , L TSTR3A.144
! LOOP VARIABLE TSTR3A.145
REAL TSTR3A.146
& TRANS(NPD_PROFILE, NPD_LAYER) TSTR3A.147
! TRANSMISSION OF LAYER TSTR3A.148
& , REFLECT(NPD_PROFILE, NPD_LAYER) TSTR3A.149
! REFLECTANCE OF LAYER TSTR3A.150
& , TRANS_0(NPD_PROFILE, NPD_LAYER) TSTR3A.151
! DIRECT TRANSMITTANCE TSTR3A.152
& , SOURCE_COEFF(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) TSTR3A.153
! SOURCE COEFFICIENTS TSTR3A.154
& , S_DOWN(NPD_PROFILE, NPD_LAYER) TSTR3A.155
! DOWNWARD SOURCE TSTR3A.156
& , S_UP(NPD_PROFILE, NPD_LAYER) TSTR3A.157
! UPWARD SOURCE TSTR3A.158
REAL TSTR3A.159
& A3(NPD_PROFILE, 3, 2*NPD_LAYER+2) TSTR3A.160
! TRIDIAGONAL MATRIX TSTR3A.161
& , A5(NPD_PROFILE, 5, 2*NPD_LAYER+2) TSTR3A.162
! PENTADIGONAL MATRIX TSTR3A.163
& , B(NPD_PROFILE, 2*NPD_LAYER+2) TSTR3A.164
! RHS OF MATRIX EQUATION TSTR3A.165
& , WORK_1(NPD_PROFILE, 2*NPD_LAYER+2) TSTR3A.166
! WORKING ARRAY FOR SOLVER TSTR3A.167
! TSTR3A.170
! SUBROUTINES CALLED: TSTR3A.171
EXTERNAL TSTR3A.172
& TWO_COEFF, SOLAR_SOURCE, IR_SOURCE TSTR3A.173
& , SET_MATRIX_PENTADIAGONAL ADB1F405.991
& , BAND_SOLVER, SOLVER_HOMOGEN_DIRECT ADB1F401.1237
! TSTR3A.177
! TSTR3A.178
! TSTR3A.179
! CALCULATE THE TWO-STREAM COEFFICIENTS. TSTR3A.180
CALL TWO_COEFF(IERR TSTR3A.181
& , N_PROFILE, 1, N_LAYER TSTR3A.182
& , I_2STREAM, L_IR_SOURCE_QUAD TSTR3A.183
& , ASYMMETRY, OMEGA, TAU TSTR3A.184
& , ISOLIR, SEC_0 TSTR3A.185
& , TRANS, REFLECT, TRANS_0 TSTR3A.186
& , SOURCE_COEFF TSTR3A.187
& , NPD_PROFILE, NPD_LAYER TSTR3A.188
& ) TSTR3A.189
IF (IERR.NE.I_NORMAL) THEN TSTR3A.190
RETURN TSTR3A.191
ENDIF TSTR3A.192
! TSTR3A.193
! CALCULATE THE APPROPRIATE SOURCE TERMS. TSTR3A.194
IF (ISOLIR.EQ.IP_SOLAR) THEN TSTR3A.195
CALL SOLAR_SOURCE(N_PROFILE, N_LAYER TSTR3A.196
& , FLUX_INC_DIRECT TSTR3A.197
& , TRANS_0, SOURCE_COEFF TSTR3A.198
& , L_SCALE_SOLAR, ADJUST_SOLAR_KE TSTR3A.199
& , FLUX_DIRECT TSTR3A.200
& , S_DOWN, S_UP TSTR3A.201
& , NPD_PROFILE, NPD_LAYER TSTR3A.202
& ) TSTR3A.203
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN TSTR3A.204
CALL IR_SOURCE(N_PROFILE, 1, N_LAYER TSTR3A.205
& , SOURCE_COEFF, DIFF_PLANCK TSTR3A.206
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_2 TSTR3A.207
& , L_2_STREAM_CORRECT, PLANCK_SOURCE TSTR3A.208
& , GROUND_EMISSION, N_LAYER TSTR3A.209
& , TAU, TRANS TSTR3A.210
& , S_DOWN, S_UP TSTR3A.211
& , NPD_PROFILE, NPD_LAYER TSTR3A.212
& ) TSTR3A.213
ENDIF TSTR3A.214
! TSTR3A.215
! TSTR3A.229
! SELECT AN APPROPRIATE SOLVER FOR THE EQUATIONS OF TRANSFER. ADB1F405.992
! TSTR3A.256
IF (I_SOLVER.EQ.IP_SOLVER_PENTADIAGONAL) THEN ADB1F405.993
CALL SET_MATRIX_PENTADIAGONAL(N_PROFILE, N_LAYER TSTR3A.268
& , TRANS, REFLECT TSTR3A.269
& , S_DOWN, S_UP TSTR3A.270
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR TSTR3A.271
& , FLUX_DIRECT(1, N_LAYER), FLUX_INC_DOWN TSTR3A.272
& , SOURCE_GROUND TSTR3A.273
& , A5, B TSTR3A.274
& , NPD_PROFILE, NPD_LAYER TSTR3A.275
& ) TSTR3A.276
N_EQUATION=2*N_LAYER+2 TSTR3A.277
! TSTR3A.278
CALL BAND_SOLVER(N_PROFILE, N_EQUATION TSTR3A.279
& , 2, 2 TSTR3A.280
& , A5, B TSTR3A.281
& , FLUX_TOTAL TSTR3A.282
& , NPD_PROFILE, 2*NPD_LAYER+2 TSTR3A.283
& , WORK_1 TSTR3A.284
& ) TSTR3A.285
! TSTR3A.286
ELSE IF (I_SOLVER.EQ.IP_SOLVER_HOMOGEN_DIRECT) THEN ADB1F401.1238
! ADB1F401.1239
CALL SOLVER_HOMOGEN_DIRECT(N_PROFILE, N_LAYER ADB1F401.1240
& , TRANS, REFLECT ADB1F401.1241
& , S_DOWN, S_UP ADB1F401.1242
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR ADB1F401.1243
& , FLUX_DIRECT(1, N_LAYER), FLUX_INC_DOWN ADB1F401.1244
& , SOURCE_GROUND ADB1F401.1245
& , FLUX_TOTAL ADB1F401.1246
& , NPD_PROFILE, NPD_LAYER ADB1F401.1247
& ) ADB1F401.1248
! ADB1F401.1249
ELSE TSTR3A.287
! ADB1F401.1250
WRITE(IU_ERR, '(/A)') TSTR3A.288
& '***ERROR: THE SOLVER AND CLOUD SCHEME ARE NOT COMPATIBLE.' TSTR3A.289
IERR=I_ERR_FATAL TSTR3A.290
RETURN TSTR3A.291
! TSTR3A.292
ENDIF TSTR3A.293
! TSTR3A.294
! ADB1F401.1251
! ADB1F401.1252
IF (L_CLEAR) THEN TSTR3A.295
! THE CLEAR FLUXES HERE CAN BE COPIED DIRECTLY WITHOUT TSTR3A.296
! ANY FURTHER CALCULATION. TSTR3A.297
IF (ISOLIR.EQ.IP_SOLAR) THEN TSTR3A.298
DO I=0, N_LAYER TSTR3A.299
DO L=1, N_PROFILE TSTR3A.300
FLUX_DIRECT_CLEAR(L, I)=FLUX_DIRECT(L, I) TSTR3A.301
ENDDO TSTR3A.302
ENDDO TSTR3A.303
ENDIF TSTR3A.304
IF (L_NET) THEN TSTR3A.305
DO I=1, N_LAYER+1 TSTR3A.306
DO L=1, N_PROFILE TSTR3A.307
FLUX_TOTAL_CLEAR(L, I)=FLUX_TOTAL(L, I) TSTR3A.308
ENDDO TSTR3A.309
ENDDO TSTR3A.310
ELSE TSTR3A.311
DO I=1, 2*N_LAYER+2 TSTR3A.312
DO L=1, N_PROFILE TSTR3A.313
FLUX_TOTAL_CLEAR(L, I)=FLUX_TOTAL(L, I) TSTR3A.314
ENDDO TSTR3A.315
ENDDO TSTR3A.316
ENDIF TSTR3A.317
ENDIF TSTR3A.318
! ADB1F401.1253
! TSTR3A.319
! TSTR3A.320
RETURN TSTR3A.321
END TSTR3A.322
*ENDIF DEF,A01_3A,OR,DEF,A02_3A TSTR3A.323
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.130