SUBROUTINE TRANS_SOURCE_COEFF(N_PROFILE 2TRSFC3A.19
& , I_LAYER_FIRST, I_LAYER_LAST TRSFC3A.20
& , ISOLIR, L_IR_SOURCE_QUAD TRSFC3A.21
& , TAU, SUM, DIFF, LAMBDA, SEC_0 TRSFC3A.22
& , GAMMA_UP, GAMMA_DOWN TRSFC3A.23
& , TRANS, REFLECT, TRANS_0, SOURCE_COEFF TRSFC3A.24
& , NPD_PROFILE, NPD_LAYER TRSFC3A.25
& ) TRSFC3A.26
! TRSFC3A.27
! TRSFC3A.28
IMPLICIT NONE TRSFC3A.29
! TRSFC3A.30
! TRSFC3A.31
! SIZES OF DUMMY ARRAYS. TRSFC3A.32
INTEGER !, INTENT(IN) TRSFC3A.33
& NPD_PROFILE TRSFC3A.34
! MAXIMUM NUMBER OF PROFILES TRSFC3A.35
& , NPD_LAYER TRSFC3A.36
! MAXIMUM NUMBER OF LAYERS TRSFC3A.37
! TRSFC3A.38
! COMDECKS INCLUDED TRSFC3A.39
*CALL DIMFIX3A 
TRSFC3A.40
*CALL SPCRG3A TRSFC3A.41
*CALL PRMCH3A TRSFC3A.42
*CALL SCFPT3A TRSFC3A.43
! TRSFC3A.44
! DUMMY VARIABLES. TRSFC3A.45
INTEGER !, INTENT(IN) TRSFC3A.46
& N_PROFILE TRSFC3A.47
! NUMBER OF PROFILES TRSFC3A.48
& , I_LAYER_FIRST TRSFC3A.49
! FIRST LAYER TO CONSIDER TRSFC3A.50
& , I_LAYER_LAST TRSFC3A.51
! LAST LAYER TO CONSIDER TRSFC3A.52
! TRSFC3A.53
! ALGORITHMIC CONTROL TRSFC3A.54
LOGICAL !, INTENT(IN) TRSFC3A.55
& L_IR_SOURCE_QUAD TRSFC3A.56
! QUADRATIC SOURCE IN INFRA-RED TRSFC3A.57
INTEGER !, INTENT(IN) TRSFC3A.58
& ISOLIR TRSFC3A.59
! SPECTRAL REGION TRSFC3A.60
! TRSFC3A.61
! OPTICAL PROPERTIES OF THE LAYER TRSFC3A.62
REAL !, INTENT(IN) TRSFC3A.63
& TAU(NPD_PROFILE, NPD_LAYER) TRSFC3A.64
! OPTICAL DEPTHS OF LAYERS TRSFC3A.65
& , SUM(NPD_PROFILE, NPD_LAYER) TRSFC3A.66
! SUM OF ALPHA_1 AND ALPHA_2 TRSFC3A.67
& , DIFF(NPD_PROFILE, NPD_LAYER) TRSFC3A.68
! DIFFERENCE OF ALPHA_1 AND ALPHA_2 TRSFC3A.69
& , LAMBDA(NPD_PROFILE, NPD_LAYER) TRSFC3A.70
! LAMBDA TRSFC3A.71
& , SEC_0(NPD_PROFILE) TRSFC3A.72
! SECANT OF SOLAR ZENITH ANGLE TRSFC3A.73
& , GAMMA_UP(NPD_PROFILE, NPD_LAYER) TRSFC3A.74
! BASIC SOLAR COEFFICIENT FOR UPWARD RADIATION TRSFC3A.75
& , GAMMA_DOWN(NPD_PROFILE, NPD_LAYER) TRSFC3A.76
! BASIC SOLAR COEFFICIENT FOR DOWNWARD RADIATION TRSFC3A.77
! TRSFC3A.78
! TRANSMISSION AND REFLECTION COEFFICIENTS AND COEFFICIENTS FOR TRSFC3A.79
! SOURCE TERMS. TRSFC3A.80
REAL !, INTENT(OUT) TRSFC3A.81
& TRANS(NPD_PROFILE, NPD_LAYER) TRSFC3A.82
! DIFFUSE TRANSMISSION COEFFICIENT TRSFC3A.83
& , REFLECT(NPD_PROFILE, NPD_LAYER) TRSFC3A.84
! DIFFUSE REFLECTION COEFFICIENT TRSFC3A.85
& , TRANS_0(NPD_PROFILE, NPD_LAYER) TRSFC3A.86
! DIRECT TRANSMISSION COEFFICIENT TRSFC3A.87
& , SOURCE_COEFF(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) TRSFC3A.88
! SOURCE COEFFICIENTS TRSFC3A.89
! TRSFC3A.90
! TRSFC3A.91
! LOCAL VARIABLES TRSFC3A.92
INTEGER TRSFC3A.93
& I TRSFC3A.94
! LOOP VARIABLE TRSFC3A.95
& , L TRSFC3A.96
! LOOP VARIABLE TRSFC3A.97
REAL TRSFC3A.98
& GAMMA TRSFC3A.99
! GAMMA TRSFC3A.100
& , EXPONENTIAL TRSFC3A.101
! EXPONENTIAL OF SCALED OPTICAL DEPTH TRSFC3A.102
REAL XLAMTAU(N_PROFILE,I_LAYER_LAST-I_LAYER_FIRST+1) !Workspace ADB6F403.1
INTEGER n_input ! No. of inputs for exp_v GSS3F402.413
! TRSFC3A.103
! ADB1F401.1232
! TRSFC3A.104
! TRSFC3A.105
! DETERMINE THE DIFFUSE TRANSMISSION AND REFLECTION COEFFICIENTS. TRSFC3A.106
! TRSFC3A.107
DO I=I_LAYER_FIRST, I_LAYER_LAST TRSFC3A.108
DO L=1, N_PROFILE TRSFC3A.109
XLAMTAU(L,I-I_LAYER_FIRST+1)=-LAMBDA(L,I)*TAU(L,I) GSS3F402.414
ENDDO GSS3F402.415
ENDDO GSS3F402.416
n_input=(I_LAYER_LAST-I_LAYER_FIRST+1)*N_PROFILE GSS3F402.417
*IF DEF,VECTLIB PXVECTLB.148
&/ PXVECTLB.149
call exp_v(n_input,xlamtau,xlamtau) ADB6F403.2
*ELSE GSS3F402.420
do I=1,I_LAYER_LAST-I_LAYER_FIRST+1 GSS3F402.421
do L=1,n_profile GSS3F402.422
xlamtau(L,I)=exp(xlamtau(L,I)) GSS3F402.423
end do GSS3F402.424
end do GSS3F402.425
*ENDIF GSS3F402.426
! GSS3F402.427
DO I=I_LAYER_FIRST, I_LAYER_LAST GSS3F402.428
DO L=1, N_PROFILE GSS3F402.429
EXPONENTIAL=xlamtau(L,I-I_LAYER_FIRST+1) GSS3F402.430
GAMMA=(SUM(L, I)-LAMBDA(L, I)) TRSFC3A.111
& /(SUM(L, I)+LAMBDA(L, I)) TRSFC3A.112
TRANS(L, I)=(EXPONENTIAL*(1.0E+00-GAMMA**2) TRSFC3A.113
& /(1.0E+00-(EXPONENTIAL*GAMMA)**2)) TRSFC3A.114
REFLECT(L, I)=GAMMA*(1.0E+00-EXPONENTIAL**2) TRSFC3A.115
& /(1.0E+00-(EXPONENTIAL*GAMMA)**2) TRSFC3A.116
ENDDO TRSFC3A.117
ENDDO TRSFC3A.118
! TRSFC3A.119
! TRSFC3A.120
! TRSFC3A.121
IF (ISOLIR.EQ.IP_SOLAR) THEN TRSFC3A.122
! TRSFC3A.123
! CALCULATE THE DIRECT TRANSMISSION AND THE SOURCE COEFFICIENTS TRSFC3A.124
! FOR THE SOLAR BEAM: IN THE SOLAR CASE THESE ARE TRSFC3A.125
! THE COEFFICIENTS WHICH WILL MULTIPLY THE DIRECT FLUX AT THE TRSFC3A.126
! TOP OF THE LAYER TO GIVE THE SOURCE TERMS FOR THE UPWARD TRSFC3A.127
! DIFFUSE FLUX AND THE TOTAL DOWNWARD FLUX. TRSFC3A.128
! TRSFC3A.129
DO I=I_LAYER_FIRST, I_LAYER_LAST TRSFC3A.130
DO L=1, N_PROFILE TRSFC3A.131
TRANS_0(L, I)=EXP(-TAU(L, I)*SEC_0(L)) TRSFC3A.132
SOURCE_COEFF(L, I, IP_SCF_SOLAR_UP) TRSFC3A.133
& =(GAMMA_UP(L, I)-REFLECT(L, I) TRSFC3A.134
& *(1.0E+00+GAMMA_DOWN(L, I))) TRSFC3A.135
& -GAMMA_UP(L, I)*TRANS(L, I)*TRANS_0(L, I) TRSFC3A.136
SOURCE_COEFF(L, I, IP_SCF_SOLAR_DOWN)=TRANS_0(L, I) TRSFC3A.137
& *(1.0E+00+GAMMA_DOWN(L, I) TRSFC3A.138
& -GAMMA_UP(L, I)*REFLECT(L, I)) TRSFC3A.139
& -(1.0E+00+GAMMA_DOWN(L, I))*TRANS(L, I) TRSFC3A.140
ENDDO TRSFC3A.141
ENDDO TRSFC3A.142
! TRSFC3A.143
! TRSFC3A.144
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN TRSFC3A.145
! TRSFC3A.146
! IN THE CASE OF INFRA-RED RADIATION, THE FIRST SOURCE TRSFC3A.147
! COEFFICIENT HOLDS THE MULTIPLIER FOR THE FIRST DIFFERENCE TRSFC3A.148
! OF THE PLANCK FUNCTION ACROSS THE LAYER, AND THE SECOND TRSFC3A.149
! THAT FOR THE SECOND DIFFERENCE. TRSFC3A.150
! TRSFC3A.151
DO I=I_LAYER_FIRST, I_LAYER_LAST TRSFC3A.152
DO L=1, N_PROFILE TRSFC3A.153
! TRSFC3A.154
! A TOLERANCE IS ADDED TO THE NUMERATOR AND THE DENOMIATOR TRSFC3A.155
! TO AVOID ILL-CONDITIONING AT SMALL OPTICAL DEPTHS. TRSFC3A.156
! TRSFC3A.157
SOURCE_COEFF(L, I, IP_SCF_IR_1D)=(1.0E+00-TRANS(L, I) TRSFC3A.158
& +REFLECT(L, I)+SQRT_TOL_MACHINE) TRSFC3A.159
& /(SQRT_TOL_MACHINE+TAU(L, I)*SUM(L, I)) TRSFC3A.160
! TRSFC3A.161
ENDDO TRSFC3A.162
ENDDO TRSFC3A.163
! TRSFC3A.164
! TRSFC3A.165
IF (L_IR_SOURCE_QUAD) THEN TRSFC3A.166
! TRSFC3A.167
! QUADRATIC CORRECTION TO SOURCE FUNCTION. TRSFC3A.168
! THIS CORRECTION IS VERY ILL-CONDITIONED FOR TRSFC3A.169
! SMALL OPTICAL DEPTHS SO THE ASYMPTOTIC FORM IS THEN USED. TRSFC3A.170
! TRSFC3A.171
EXPONENTIAL = EXP(3.3E-01*LOG(TOL_MACHINE)) GRB0F405.3
DO I=I_LAYER_FIRST, I_LAYER_LAST TRSFC3A.172
DO L=1, N_PROFILE TRSFC3A.173
! ADB2F404.1711
! USE A SEPARATE ASYMPTOTIC FORM WHEN THE OPTICAL ADB2F404.1712
! DEPTH IS SMALL, MAKING THE TRANSITION WHEN THE ADB2F404.1713
! OPTICAL DEPTH IS ROUGHLY EQUAL TO THE CUBE ROOT ADB2F404.1714
! OF THE MACHINE'S PRECISION. ADB2F404.1715
! ADB2F404.1716
IF (TAU(L, I).GT.EXPONENTIAL) THEN GRB0F405.4
SOURCE_COEFF(L, I, IP_SCF_IR_2D) TRSFC3A.175
& =-2.0E+00*(1.0E+00-TRANS(L, I)-REFLECT(L, I) TRSFC3A.176
& +SQRT_TOL_MACHINE) TRSFC3A.177
& /(DIFF(L, I)*TAU(L, I)+SQRT_TOL_MACHINE) TRSFC3A.178
ELSE TRSFC3A.179
SOURCE_COEFF(L, I, IP_SCF_IR_2D) TRSFC3A.180
& =-2.0E+00+DIFF(L, I)*TAU(L, I) TRSFC3A.181
ENDIF TRSFC3A.182
! ADB2F404.1717
SOURCE_COEFF(L, I, IP_SCF_IR_2D) TRSFC3A.183
& =-(1.0E+00+REFLECT(L, I)+TRANS(L, I) TRSFC3A.184
& +SOURCE_COEFF(L, I, IP_SCF_IR_2D)) ADB1F401.1234
& /(SUM(L, I)*TAU(L, I)+SQRT_TOL_MACHINE) TRSFC3A.187
! ADB2F404.1718
ENDDO TRSFC3A.188
ENDDO TRSFC3A.189
! TRSFC3A.190
ENDIF TRSFC3A.191
! TRSFC3A.192
ENDIF TRSFC3A.193
! TRSFC3A.194
! TRSFC3A.195
! TRSFC3A.196
RETURN TRSFC3A.197
END TRSFC3A.198
*ENDIF DEF,A01_3A,OR,DEF,A02_3A TRSFC3A.199
*ENDIF DEF,A70_1A ADB1F402.142