SUBROUTINE CLEAR_SUPPLEMENT(IERR, N_PROFILE, N_LAYER 3,4CLRSP3A.21
& , I_SOLVER_CLEAR CLRSP3A.22
& , TRANS_FREE, REFLECT_FREE, TRANS_0_FREE, SOURCE_COEFF_FREE CLRSP3A.23
& , ISOLIR, FLUX_INC_DIRECT, FLUX_INC_DOWN CLRSP3A.24
& , S_DOWN_FREE, S_UP_FREE CLRSP3A.25
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR CLRSP3A.26
& , SOURCE_GROUND CLRSP3A.27
& , L_SCALE_SOLAR, ADJUST_SOLAR_KE CLRSP3A.28
& , FLUX_DIRECT_CLEAR, FLUX_TOTAL_CLEAR CLRSP3A.29
& , NPD_PROFILE, NPD_LAYER CLRSP3A.30
& ) CLRSP3A.31
! CLRSP3A.32
! CLRSP3A.33
IMPLICIT NONE CLRSP3A.34
! CLRSP3A.35
! CLRSP3A.36
! SIZES OF DUMMY ARRAYS. CLRSP3A.37
INTEGER !, INTENT(IN) CLRSP3A.38
& NPD_PROFILE CLRSP3A.39
! MAXIMUM NUMBER OF PROFILES CLRSP3A.40
& , NPD_LAYER CLRSP3A.41
! MAXIMUM NUMBER OF LAYERS CLRSP3A.42
! CLRSP3A.43
! INCLUDE COMDECKS. CLRSP3A.44
*CALL STDIO3A 
CLRSP3A.45
*CALL SPCRG3A CLRSP3A.46
*CALL SOLVER3A CLRSP3A.47
*CALL ERROR3A CLRSP3A.48
! CLRSP3A.49
! DUMMY VARIABLES. CLRSP3A.50
INTEGER !, INTENT(OUT) CLRSP3A.51
& IERR CLRSP3A.52
! ERROR FLAG CLRSP3A.53
INTEGER !, INTENT(IN) CLRSP3A.54
& N_PROFILE CLRSP3A.55
! NUMBER OF PROFILES CLRSP3A.56
& , N_LAYER CLRSP3A.57
! NUMBER OF LAYERS CLRSP3A.58
& , ISOLIR CLRSP3A.59
! SPECTRAL REGION CLRSP3A.60
& , I_SOLVER_CLEAR CLRSP3A.61
! SOLVER FOR CLEAR FLUXES CLRSP3A.62
LOGICAL !, INTENT(IN) CLRSP3A.63
& L_SCALE_SOLAR CLRSP3A.64
! SCALING APPLIED TO SOLAR BEAM CLRSP3A.65
REAL !, INTENT(IN) CLRSP3A.66
& TRANS_FREE(NPD_PROFILE, NPD_LAYER) CLRSP3A.67
! TRANSMISSION COEFFICIENTS CLRSP3A.68
& , REFLECT_FREE(NPD_PROFILE, NPD_LAYER) CLRSP3A.69
! REFLECTION COEFFICIENTS CLRSP3A.70
& , TRANS_0_FREE(NPD_PROFILE, NPD_LAYER) CLRSP3A.71
! DIRECT TRANSMISSION COEFFICIENTS CLRSP3A.72
& , SOURCE_COEFF_FREE(NPD_PROFILE, NPD_LAYER) CLRSP3A.73
! COEFFICIENTS IN SOURCE TERMS CLRSP3A.74
& , S_DOWN_FREE(NPD_PROFILE, NPD_LAYER) CLRSP3A.75
! DOWNWARD SOURCE CLRSP3A.76
& , S_UP_FREE(NPD_PROFILE, NPD_LAYER) CLRSP3A.77
! UPWARD SOURCE CLRSP3A.78
& , ALBEDO_SURFACE_DIFF(NPD_PROFILE) CLRSP3A.79
! DIFFUSE ALBEDO CLRSP3A.80
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) CLRSP3A.81
! DIRECT ALBEDO CLRSP3A.82
& , FLUX_INC_DOWN(NPD_PROFILE) CLRSP3A.83
! INCIDENT TOTAL FLUX CLRSP3A.84
& , FLUX_INC_DIRECT(NPD_PROFILE) CLRSP3A.85
! INCIDENT DIRECT FLUX CLRSP3A.86
& , SOURCE_GROUND(NPD_PROFILE) CLRSP3A.87
! GROUND SOURCE FUNCTION CLRSP3A.88
& , ADJUST_SOLAR_KE(NPD_PROFILE, NPD_LAYER) CLRSP3A.89
! SCALING OF SOLAR BEAM CLRSP3A.90
! CLRSP3A.91
! CLRSP3A.92
REAL !, INTENT(OUT) CLRSP3A.93
& FLUX_DIRECT_CLEAR(NPD_PROFILE, 0: NPD_LAYER) CLRSP3A.94
! CLEAR DIRECT FLUX CLRSP3A.95
& , FLUX_TOTAL_CLEAR(NPD_PROFILE, 2*NPD_LAYER+2) CLRSP3A.96
! CLEAR TOTAL FLUXES CLRSP3A.97
! CLRSP3A.98
! CLRSP3A.99
! DUMMY VARIABALES. CLRSP3A.100
INTEGER CLRSP3A.101
& N_EQUATION CLRSP3A.102
! NUMBER OF EQUATIONS CLRSP3A.103
REAL CLRSP3A.104
& A3(NPD_PROFILE, 3, 2*NPD_LAYER+2) CLRSP3A.105
! TRIDIAGONAL MATRIX CLRSP3A.106
& , A5(NPD_PROFILE, 5, 2*NPD_LAYER+2) CLRSP3A.107
! PENTADIAGONAL MATRIX CLRSP3A.108
& , B(NPD_PROFILE, 2*NPD_LAYER+2) CLRSP3A.109
! RHS OF MATRIX EQUATION CLRSP3A.110
& , WORK_1(NPD_PROFILE, 2*NPD_LAYER+2) CLRSP3A.111
! WORKING ARRAY FOR SOLVER CLRSP3A.112
& , WORK_2(NPD_PROFILE, 2*NPD_LAYER+2) CLRSP3A.113
! WORKING ARRAY FOR SOLVER CLRSP3A.114
! CLRSP3A.115
! SUBROUTINES CALLED: CLRSP3A.116
EXTERNAL CLRSP3A.117
*IF DEF,SCMA AJC0F405.292
& SOLAR_SOURCE AJC0F405.293
*ELSE AJC0F405.294
& SOLAR_SOURCE, SET_MATRIX_NET, TRIDIAG_SOLVER_UP AJC0F405.295
*ENDIF AJC0F405.296
& , SET_MATRIX_FULL, SET_MATRIX_PENTADIAGONAL CLRSP3A.119
& , BAND_SOLVER, SOLVER_HOMOGEN_DIRECT ADB1F401.33
! CLRSP3A.121
! CLRSP3A.122
! THE SOURCE FUNCTIONS ONLY NEED TO BE RECALCULATED IN THE VISIBLE. CLRSP3A.123
IF (ISOLIR.EQ.IP_SOLAR) THEN CLRSP3A.124
CALL SOLAR_SOURCE(N_PROFILE, N_LAYER CLRSP3A.125
& , FLUX_INC_DIRECT CLRSP3A.126
& , TRANS_0_FREE, SOURCE_COEFF_FREE CLRSP3A.127
& , L_SCALE_SOLAR, ADJUST_SOLAR_KE CLRSP3A.128
& , FLUX_DIRECT_CLEAR CLRSP3A.129
& , S_DOWN_FREE, S_UP_FREE CLRSP3A.130
& , NPD_PROFILE, NPD_LAYER CLRSP3A.131
& ) CLRSP3A.132
ENDIF CLRSP3A.133
! CLRSP3A.134
! CLRSP3A.146
! SELECT AN APPROPRIATE SOLVER FOR THE EQUATIONS OF TRANSFER. ADB1F405.10
! CLRSP3A.154
IF (I_SOLVER_CLEAR.EQ.IP_SOLVER_PENTADIAGONAL) THEN ADB1F405.11
! ADB1F401.35
! CALCULATE THE ELEMENTS OF THE MATRIX EQUATIONS. ADB1F401.36
CALL SET_MATRIX_PENTADIAGONAL(N_PROFILE, N_LAYER CLRSP3A.177
& , TRANS_FREE, REFLECT_FREE CLRSP3A.178
& , S_DOWN_FREE, S_UP_FREE CLRSP3A.179
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR CLRSP3A.180
& , FLUX_DIRECT_CLEAR(1, N_LAYER), FLUX_INC_DOWN CLRSP3A.181
& , SOURCE_GROUND CLRSP3A.182
& , A5, B CLRSP3A.183
& , NPD_PROFILE, NPD_LAYER CLRSP3A.184
& ) CLRSP3A.185
N_EQUATION=2*N_LAYER+2 CLRSP3A.186
! CLRSP3A.187
CALL BAND_SOLVER(N_PROFILE, N_EQUATION CLRSP3A.188
& , 2, 2 CLRSP3A.189
& , A5, B CLRSP3A.190
& , FLUX_TOTAL_CLEAR CLRSP3A.191
& , NPD_PROFILE, 2*NPD_LAYER+2 CLRSP3A.192
& , WORK_1 CLRSP3A.193
& ) CLRSP3A.194
! CLRSP3A.195
ELSE IF (I_SOLVER_CLEAR.EQ.IP_SOLVER_HOMOGEN_DIRECT) THEN ADB1F401.37
! ADB1F401.38
! SOLVE FOR THE FLUXES IN THE COLUMN DIRECTLY. ADB1F401.39
CALL SOLVER_HOMOGEN_DIRECT(N_PROFILE, N_LAYER ADB1F401.40
& , TRANS_FREE, REFLECT_FREE ADB1F401.41
& , S_DOWN_FREE, S_UP_FREE ADB1F401.42
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR ADB1F401.43
& , FLUX_DIRECT_CLEAR(1, N_LAYER), FLUX_INC_DOWN ADB1F401.44
& , SOURCE_GROUND ADB1F401.45
& , FLUX_TOTAL_CLEAR ADB1F401.46
& , NPD_PROFILE, NPD_LAYER ADB1F401.47
& ) ADB1F401.48
! ADB1F401.49
ELSE CLRSP3A.196
! ADB1F401.50
WRITE(IU_ERR, '(/A)') CLRSP3A.197
& '*** ERROR: THE SOLVER SPECIFIED IS NOT VALID ' CLRSP3A.198
& //'FOR CLEAR FLUXES.' CLRSP3A.199
IERR=I_ERR_FATAL CLRSP3A.200
RETURN CLRSP3A.201
! CLRSP3A.202
ENDIF CLRSP3A.203
! ADB1F401.51
! CLRSP3A.204
! CLRSP3A.205
RETURN CLRSP3A.206
END CLRSP3A.207
*ENDIF DEF,A01_3A,OR,DEF,A02_3A CLRSP3A.208
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.14