SUBROUTINE IR_SOURCE(N_PROFILE, I_LAYER_FIRST, I_LAYER_LAST 6,4IRS3A.23
& , SOURCE_COEFF, DEL_PLANCK, L_IR_SOURCE_QUAD, DIFF_PLANCK_2 IRS3A.24
& , L_2_STREAM_CORRECT, PLANCK_SOURCE IRS3A.25
& , GROUND_EMISSION, N_LAYER IRS3A.26
& , TAU, TRANS IRS3A.27
& , S_DOWN, S_UP IRS3A.28
& , NPD_PROFILE, NPD_LAYER IRS3A.29
& ) IRS3A.30
! IRS3A.31
! IRS3A.32
! IRS3A.33
IMPLICIT NONE IRS3A.34
! IRS3A.35
! IRS3A.36
! SIZES OF DUMMY ARRAYS. IRS3A.37
INTEGER !, INTENT(IN) IRS3A.38
& NPD_PROFILE IRS3A.39
! MAXIMUM NUMBER OF PROFILES IRS3A.40
& , NPD_LAYER IRS3A.41
! MAXIMUM NUMBER OF LAYERS IRS3A.42
! IRS3A.43
! INCLUDE COMDECKS. IRS3A.44
*CALL DIMFIX3A 
IRS3A.45
*CALL SCFPT3A IRS3A.46
! IRS3A.47
! DUMMY VARIABLES. IRS3A.48
INTEGER !, INTENT(IN) IRS3A.49
& N_PROFILE IRS3A.50
! NUMBER OF PROFILES IRS3A.51
& , I_LAYER_FIRST IRS3A.52
! FIRST LAYER TO CONSIDER IRS3A.53
& , I_LAYER_LAST IRS3A.54
! LAST LAYER TO CONSIDER IRS3A.55
& , N_LAYER IRS3A.56
! NUMBER OF LAYERS IRS3A.57
! IRS3A.58
LOGICAL !, INTENT(IN) IRS3A.59
& L_IR_SOURCE_QUAD IRS3A.60
! USE A QUADRATIC REPRESENTATION IRS3A.61
& , L_2_STREAM_CORRECT IRS3A.62
! EDGE CORRECTION TO 2-STREAM IRS3A.63
! IRS3A.64
REAL !, INTENT(IN) IRS3A.65
& SOURCE_COEFF(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) IRS3A.66
! COEFFICIENTS FOR SOURCE TERMS IRS3A.67
& , DEL_PLANCK(NPD_PROFILE, NPD_LAYER) IRS3A.68
! DIFFERENCE IN PLANCK FUNCTION ACROSS THE LAYER IRS3A.69
& , DIFF_PLANCK_2(NPD_PROFILE, NPD_LAYER) IRS3A.70
! 2x2ND DIFFERENCE OF PLANCKIAN IRS3A.71
& , TAU(NPD_PROFILE, NPD_LAYER) IRS3A.72
! OPTCIAL DEPTH IRS3A.73
& , TRANS(NPD_PROFILE, NPD_LAYER) IRS3A.74
! TRANSMISSION COEFFICIENT IRS3A.75
& , PLANCK_SOURCE(NPD_PROFILE, 0: NPD_LAYER) IRS3A.76
! PLANCKIAN SOURCE FUNCTION IRS3A.77
& , GROUND_EMISSION(NPD_PROFILE) IRS3A.78
! TOTAL FLUX EMITTED FROM GROUND IRS3A.79
! IRS3A.80
REAL !, INTENT(OUT) IRS3A.81
& S_DOWN(NPD_PROFILE, NPD_LAYER) IRS3A.82
! UPWARD SOURCE FUNCTION IRS3A.83
& , S_UP(NPD_PROFILE, NPD_LAYER) IRS3A.84
! UPWARD SOURCE FUNCTION IRS3A.85
! IRS3A.86
! IRS3A.87
! LOCAL VARIABLES. IRS3A.88
! IRS3A.89
INTEGER IRS3A.90
& I IRS3A.91
! LOOP VARIABLE IRS3A.92
& , L IRS3A.93
! LOOP VARIABLE IRS3A.94
! IRS3A.95
REAL IRS3A.96
& TAUC(NPD_PROFILE, 0: NPD_LAYER) IRS3A.97
! CUMULATIVE OPTICAL DEPTH IRS3A.98
& , PLANCK_AVE(NPD_PROFILE, 0: NPD_LAYER) IRS3A.99
! AVERAGE PLANCKIAN IRS3A.100
& , DELTA_TAU_UP_TOP IRS3A.101
! OPTICAL DEPTH: SURF-TOP OF LAYER IRS3A.102
& , DELTA_TAU_UP_BASE IRS3A.103
! OPTICAL DEPTH: SURF-BASE OF LAYER IRS3A.104
! IRS3A.105
! FUNCTIONS CALLED: IRS3A.106
REAL IRS3A.107
& E3_ACC01 IRS3A.108
! THIRD EXPONENTIAL INTEGRAL TO 1% IRS3A.109
EXTERNAL IRS3A.110
& E3_ACC01 IRS3A.111
! IRS3A.112
! IRS3A.113
! IRS3A.114
! MULTIPLY THE SOURCE COEFFICIENTS BY THE PLANCKIAN DIFFERENCES IRS3A.115
! TO THE ORDER REQUIRED. IRS3A.116
! IRS3A.117
IF (L_IR_SOURCE_QUAD) THEN IRS3A.118
! IRS3A.119
DO I=I_LAYER_FIRST, I_LAYER_LAST IRS3A.120
DO L=1, N_PROFILE IRS3A.121
S_UP(L, I)=SOURCE_COEFF(L, I, IP_SCF_IR_1D) IRS3A.122
& *DEL_PLANCK(L, I) IRS3A.123
& +SOURCE_COEFF(L, I, IP_SCF_IR_2D) IRS3A.124
& *DIFF_PLANCK_2(L, I) IRS3A.125
S_DOWN(L, I)=-SOURCE_COEFF(L, I, IP_SCF_IR_1D) IRS3A.126
& *DEL_PLANCK(L, I) IRS3A.127
& +SOURCE_COEFF(L, I, IP_SCF_IR_2D) IRS3A.128
& *DIFF_PLANCK_2(L, I) IRS3A.129
ENDDO IRS3A.130
! IRS3A.131
ENDDO IRS3A.132
! IRS3A.133
ELSE IRS3A.134
! IRS3A.135
DO I=I_LAYER_FIRST, I_LAYER_LAST IRS3A.136
DO L=1, N_PROFILE IRS3A.137
S_UP(L, I)=SOURCE_COEFF(L, I, IP_SCF_IR_1D) IRS3A.138
& *DEL_PLANCK(L, I) IRS3A.139
S_DOWN(L, I)=-S_UP(L, I) IRS3A.140
ENDDO IRS3A.141
ENDDO IRS3A.142
! IRS3A.143
ENDIF IRS3A.144
! IRS3A.145
! IRS3A.146
! EDGE CORRECTIONS TO 2-STREAM EQUATIONS. IRS3A.147
! IRS3A.148
IF (L_2_STREAM_CORRECT) THEN IRS3A.149
! IRS3A.150
DO L=1, N_PROFILE IRS3A.151
TAUC(L, 0)=0.0E+00 IRS3A.152
ENDDO IRS3A.153
DO I=1, N_LAYER IRS3A.154
DO L=1, N_PROFILE IRS3A.155
TAUC(L, I)=TAUC(L, I-1)+TAU(L, I) IRS3A.156
PLANCK_AVE(L, I) IRS3A.157
& =0.5E+00*(PLANCK_SOURCE(L, I-1)+PLANCK_SOURCE(L, I)) IRS3A.158
ENDDO IRS3A.159
ENDDO IRS3A.160
! IRS3A.161
DO I=1, N_LAYER IRS3A.162
DO L=1, N_PROFILE IRS3A.163
DELTA_TAU_UP_TOP=TAUC(L, N_LAYER)-TAUC(L, I-1) IRS3A.164
DELTA_TAU_UP_BASE=TAUC(L, N_LAYER)-TAUC(L, I) IRS3A.165
S_UP(L, I)=S_UP(L, I) IRS3A.166
& +2.0E+00*(GROUND_EMISSION(L)-PLANCK_AVE(L, I)) IRS3A.167
& *(E3_ACC01(DELTA_TAU_UP_TOP) IRS3A.168
& -TRANS(L, I)*E3_ACC01(DELTA_TAU_UP_BASE)) IRS3A.169
S_DOWN(L, I)=S_DOWN(L, I) IRS3A.170
& +2.0E+00*PLANCK_AVE(L, I) IRS3A.171
& *(TRANS(L, I)*E3_ACC01(TAUC(L, I-1)) IRS3A.172
& -E3_ACC01(TAUC(L, I))) IRS3A.173
ENDDO IRS3A.174
ENDDO IRS3A.175
IRS3A.176
ENDIF IRS3A.177
! IRS3A.178
! IRS3A.179
! IRS3A.180
RETURN IRS3A.181
END IRS3A.182
*ENDIF DEF,A01_3A,OR,DEF,A02_3A IRS3A.183
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.38