SUBROUTINE TRANS_SOURCE_COEFF(N_PROFILE 2TRSFC3B.38
& , I_LAYER_FIRST, I_LAYER_LAST TRSFC3B.39
& , ISOLIR, L_IR_SOURCE_QUAD TRSFC3B.40
& , TAU, SUM, DIFF, LAMBDA, SEC_0 TRSFC3B.41
& , GAMMA_UP, GAMMA_DOWN TRSFC3B.42
& , TRANS, REFLECT, TRANS_0, SOURCE_COEFF TRSFC3B.43
& , NPD_PROFILE, NPD_LAYER TRSFC3B.44
& ) TRSFC3B.45
! TRSFC3B.46
! TRSFC3B.47
IMPLICIT NONE TRSFC3B.48
! TRSFC3B.49
! TRSFC3B.50
! SIZES OF DUMMY ARRAYS. TRSFC3B.51
INTEGER !, INTENT(IN) TRSFC3B.52
& NPD_PROFILE TRSFC3B.53
! MAXIMUM NUMBER OF PROFILES TRSFC3B.54
& , NPD_LAYER TRSFC3B.55
! MAXIMUM NUMBER OF LAYERS TRSFC3B.56
! TRSFC3B.57
! COMDECKS INCLUDED TRSFC3B.58
*CALL DIMFIX3A 
TRSFC3B.59
*CALL SPCRG3A TRSFC3B.60
*CALL PRMCH3A TRSFC3B.61
*CALL SCFPT3A TRSFC3B.62
! TRSFC3B.63
! DUMMY VARIABLES. TRSFC3B.64
INTEGER !, INTENT(IN) TRSFC3B.65
& N_PROFILE TRSFC3B.66
! NUMBER OF PROFILES TRSFC3B.67
& , I_LAYER_FIRST TRSFC3B.68
! FIRST LAYER TO CONSIDER TRSFC3B.69
& , I_LAYER_LAST TRSFC3B.70
! LAST LAYER TO CONSIDER TRSFC3B.71
! TRSFC3B.72
! ALGORITHMIC CONTROL TRSFC3B.73
LOGICAL !, INTENT(IN) TRSFC3B.74
& L_IR_SOURCE_QUAD TRSFC3B.75
! QUADRATIC SOURCE IN INFRA-RED TRSFC3B.76
INTEGER !, INTENT(IN) TRSFC3B.77
& ISOLIR TRSFC3B.78
! SPECTRAL REGION TRSFC3B.79
! TRSFC3B.80
! OPTICAL PROPERTIES OF THE LAYER TRSFC3B.81
REAL !, INTENT(IN) TRSFC3B.82
& TAU(NPD_PROFILE, NPD_LAYER) TRSFC3B.83
! OPTICAL DEPTHS OF LAYERS TRSFC3B.84
& , SUM(NPD_PROFILE, NPD_LAYER) TRSFC3B.85
! SUM OF ALPHA_1 AND ALPHA_2 TRSFC3B.86
& , DIFF(NPD_PROFILE, NPD_LAYER) TRSFC3B.87
! DIFFERENCE OF ALPHA_1 AND ALPHA_2 TRSFC3B.88
& , LAMBDA(NPD_PROFILE, NPD_LAYER) TRSFC3B.89
! LAMBDA TRSFC3B.90
& , SEC_0(NPD_PROFILE) TRSFC3B.91
! SECANT OF SOLAR ZENITH ANGLE TRSFC3B.92
& , GAMMA_UP(NPD_PROFILE, NPD_LAYER) TRSFC3B.93
! BASIC SOLAR COEFFICIENT FOR UPWARD RADIATION TRSFC3B.94
& , GAMMA_DOWN(NPD_PROFILE, NPD_LAYER) TRSFC3B.95
! BASIC SOLAR COEFFICIENT FOR DOWNWARD RADIATION TRSFC3B.96
! TRSFC3B.97
! TRANSMISSION AND REFLECTION COEFFICIENTS AND COEFFICIENTS FOR TRSFC3B.98
! SOURCE TERMS. TRSFC3B.99
REAL !, INTENT(OUT) TRSFC3B.100
& TRANS(NPD_PROFILE, NPD_LAYER) TRSFC3B.101
! DIFFUSE TRANSMISSION COEFFICIENT TRSFC3B.102
& , REFLECT(NPD_PROFILE, NPD_LAYER) TRSFC3B.103
! DIFFUSE REFLECTION COEFFICIENT TRSFC3B.104
& , TRANS_0(NPD_PROFILE, NPD_LAYER) TRSFC3B.105
! DIRECT TRANSMISSION COEFFICIENT TRSFC3B.106
& , SOURCE_COEFF(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) TRSFC3B.107
! SOURCE COEFFICIENTS TRSFC3B.108
! TRSFC3B.109
! TRSFC3B.110
! LOCAL VARIABLES TRSFC3B.111
INTEGER TRSFC3B.112
& I TRSFC3B.113
! LOOP VARIABLE TRSFC3B.114
& , L TRSFC3B.115
! LOOP VARIABLE TRSFC3B.116
REAL TRSFC3B.117
& GAMMA TRSFC3B.118
! GAMMA TRSFC3B.119
& , EXPONENTIAL TRSFC3B.120
! EXPONENTIAL OF SCALED OPTICAL DEPTH TRSFC3B.121
REAL XLAMTAU(N_PROFILE,I_LAYER_LAST-I_LAYER_FIRST+1) !Workspace TRSFC3B.122
INTEGER n_input ! No. of inputs for exp_v TRSFC3B.123
REAL TMP_INV, TEMP_NUM2,TEMP_DEN2 TRSFC3B.124
REAL TEMP_NUM1,TEMP_DEN1 TRSFC3B.125
REAL TEMP(NPD_PROFILE) TRSFC3B.126
! TRSFC3B.127
! TRSFC3B.128
! TRSFC3B.129
! TRSFC3B.130
! DETERMINE THE DIFFUSE TRANSMISSION AND REFLECTION COEFFICIENTS. TRSFC3B.131
! TRSFC3B.132
DO I=I_LAYER_FIRST, I_LAYER_LAST TRSFC3B.133
DO L=1, N_PROFILE TRSFC3B.134
XLAMTAU(L,I-I_LAYER_FIRST+1)=-LAMBDA(L,I)*TAU(L,I) TRSFC3B.135
ENDDO TRSFC3B.136
ENDDO TRSFC3B.137
n_input=(I_LAYER_LAST-I_LAYER_FIRST+1)*N_PROFILE TRSFC3B.138
*IF DEF,VECTLIB PXVECTLB.150
call exp_v(n_input,xlamtau,xlamtau) TRSFC3B.140
*ELSE TRSFC3B.141
do I=1,I_LAYER_LAST-I_LAYER_FIRST+1 TRSFC3B.142
do L=1,n_profile TRSFC3B.143
xlamtau(L,I)=exp(xlamtau(L,I)) TRSFC3B.144
end do TRSFC3B.145
end do TRSFC3B.146
*ENDIF TRSFC3B.147
! TRSFC3B.148
DO I=I_LAYER_FIRST, I_LAYER_LAST TRSFC3B.149
DO L=1, N_PROFILE TRSFC3B.150
EXPONENTIAL=xlamtau(L,I-I_LAYER_FIRST+1) TRSFC3B.151
GAMMA=(SUM(L, I)-LAMBDA(L, I)) TRSFC3B.152
& /(SUM(L, I)+LAMBDA(L, I)) TRSFC3B.153
TMP_INV = 1.0E+00 TRSFC3B.154
& /(1.0E+00-(EXPONENTIAL*GAMMA)**2) TRSFC3B.155
TRANS(L, I)=EXPONENTIAL*(1.0E+00-GAMMA**2) TRSFC3B.156
& *TMP_INV TRSFC3B.157
REFLECT(L, I)=GAMMA*(1.0E+00-EXPONENTIAL**2) TRSFC3B.158
& *TMP_INV TRSFC3B.159
ENDDO TRSFC3B.160
ENDDO TRSFC3B.161
! TRSFC3B.162
! TRSFC3B.163
! TRSFC3B.164
IF (ISOLIR.EQ.IP_SOLAR) THEN TRSFC3B.165
! TRSFC3B.166
! CALCULATE THE DIRECT TRANSMISSION AND THE SOURCE COEFFICIENTS TRSFC3B.167
! FOR THE SOLAR BEAM: IN THE SOLAR CASE THESE ARE TRSFC3B.168
! THE COEFFICIENTS WHICH WILL MULTIPLY THE DIRECT FLUX AT THE TRSFC3B.169
! TOP OF THE LAYER TO GIVE THE SOURCE TERMS FOR THE UPWARD TRSFC3B.170
! DIFFUSE FLUX AND THE TOTAL DOWNWARD FLUX. TRSFC3B.171
! TRSFC3B.172
DO I=I_LAYER_FIRST, I_LAYER_LAST TRSFC3B.173
*IF DEF,VECTLIB PXVECTLB.151
DO L=1, N_PROFILE TRSFC3B.175
TEMP(L) = -TAU(L,I)*SEC_0(L) TRSFC3B.176
END DO TRSFC3B.177
CALL EXP_V(N_PROFILE,TEMP,TRANS_0(1,I)) TRSFC3B.178
*ELSE TRSFC3B.179
DO L=1, N_PROFILE TRSFC3B.180
TRANS_0(L, I)=EXP(-TAU(L, I)*SEC_0(L)) TRSFC3B.181
ENDDO TRSFC3B.182
*ENDIF TRSFC3B.183
TRSFC3B.184
DO L=1,N_PROFILE TRSFC3B.185
SOURCE_COEFF(L,I,IP_SCF_SOLAR_UP) TRSFC3B.186
& = (GAMMA_UP(L,I) - REFLECT(L,I) TRSFC3B.187
& *(1.0E+00+GAMMA_DOWN(L,I))) TRSFC3B.188
SOURCE_COEFF(L,I,IP_SCF_SOLAR_DOWN) TRSFC3B.189
& =(1.0E+00+GAMMA_DOWN(L,I) TRSFC3B.190
& -GAMMA_UP(L,I)*REFLECT(L,I)) TRSFC3B.191
END DO TRSFC3B.192
DO L=1,N_PROFILE TRSFC3B.193
SOURCE_COEFF(L,I,IP_SCF_SOLAR_UP) TRSFC3B.194
& = SOURCE_COEFF(L,I,IP_SCF_SOLAR_UP) TRSFC3B.195
& -GAMMA_UP(L,I)*TRANS(L,I)*TRANS_0(L,I) TRSFC3B.196
END DO TRSFC3B.197
DO L=1,N_PROFILE TRSFC3B.198
SOURCE_COEFF(L,I,IP_SCF_SOLAR_DOWN) TRSFC3B.199
& = TRANS_0(L,I)*SOURCE_COEFF(L,I,IP_SCF_SOLAR_DOWN) TRSFC3B.200
& -(1.0E+00+GAMMA_DOWN(L,I))*TRANS(L,I) TRSFC3B.201
END DO TRSFC3B.202
ENDDO TRSFC3B.203
! TRSFC3B.204
! TRSFC3B.205
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN TRSFC3B.206
! TRSFC3B.207
! IN THE CASE OF INFRA-RED RADIATION, THE FIRST SOURCE TRSFC3B.208
! COEFFICIENT HOLDS THE MULTIPLIER FOR THE FIRST DIFFERENCE TRSFC3B.209
! OF THE PLANCK FUNCTION ACROSS THE LAYER, AND THE SECOND TRSFC3B.210
! THAT FOR THE SECOND DIFFERENCE. TRSFC3B.211
! TRSFC3B.212
DO I=I_LAYER_FIRST, I_LAYER_LAST TRSFC3B.213
DO L=1, N_PROFILE TRSFC3B.214
TRSFC3B.215
! A TOLERANCE IS ADDED TO THE NUMERATOR AND THE DENOMIATOR TRSFC3B.216
! TO AVOID ILL-CONDITIONING AT SMALL OPTICAL DEPTHS. TRSFC3B.217
! TRSFC3B.218
SOURCE_COEFF(L, I, IP_SCF_IR_1D)=(1.0E+00-TRANS(L, I) TRSFC3B.219
& +REFLECT(L, I)+SQRT_TOL_MACHINE) TRSFC3B.220
& /(SQRT_TOL_MACHINE+TAU(L, I)*SUM(L, I)) TRSFC3B.221
TRSFC3B.222
ENDDO TRSFC3B.223
ENDDO TRSFC3B.224
! TRSFC3B.225
! TRSFC3B.226
IF (L_IR_SOURCE_QUAD) THEN TRSFC3B.227
! TRSFC3B.228
! QUADRATIC CORRECTION TO SOURCE FUNCTION. TRSFC3B.229
! THIS CORRECTION IS VERY ILL-CONDITIONED FOR TRSFC3B.230
! SMALL OPTICAL DEPTHS SO THE ASYMPTOTIC FORM IS THEN USED. TRSFC3B.231
! TRSFC3B.232
DO I=I_LAYER_FIRST, I_LAYER_LAST TRSFC3B.233
DO L=1, N_PROFILE TRSFC3B.234
! TRSFC3B.235
! USE A SEPARATE ASYMPTOTIC FORM WHEN THE OPTICAL TRSFC3B.236
! DEPTH IS SMALL, MAKING THE TRANSITION WHEN THE TRSFC3B.237
! OPTICAL DEPTH IS ROUGHLY EQUAL TO THE CUBE ROOT TRSFC3B.238
! OF THE MACHINE'S PRECISION. TRSFC3B.239
! TRSFC3B.240
IF (TAU(L, I).GT.EXP(3.3E-01*LOG(TOL_MACHINE))) THEN TRSFC3B.241
SOURCE_COEFF(L, I, IP_SCF_IR_2D) TRSFC3B.242
& =-2.0E+00*(1.0E+00-TRANS(L, I)-REFLECT(L, I) TRSFC3B.243
& +SQRT_TOL_MACHINE) TRSFC3B.244
& /(DIFF(L, I)*TAU(L, I)+SQRT_TOL_MACHINE) TRSFC3B.245
ELSE TRSFC3B.246
SOURCE_COEFF(L, I, IP_SCF_IR_2D) TRSFC3B.247
& =-2.0E+00+DIFF(L, I)*TAU(L, I) TRSFC3B.248
ENDIF TRSFC3B.249
! TRSFC3B.250
END DO TRSFC3B.251
END DO TRSFC3B.252
TRSFC3B.253
DO I=I_LAYER_FIRST, I_LAYER_LAST TRSFC3B.254
DO L=1, N_PROFILE TRSFC3B.255
SOURCE_COEFF(L, I, IP_SCF_IR_2D) TRSFC3B.256
& =-(1.0E+00+REFLECT(L, I)+TRANS(L, I) TRSFC3B.257
& +SOURCE_COEFF(L, I, IP_SCF_IR_2D)) TRSFC3B.258
& /(SUM(L, I)*TAU(L, I)+SQRT_TOL_MACHINE) TRSFC3B.259
ENDDO TRSFC3B.260
ENDDO TRSFC3B.261
! TRSFC3B.262
ENDIF TRSFC3B.263
! TRSFC3B.264
ENDIF TRSFC3B.265
! TRSFC3B.266
RETURN TRSFC3B.267
END TRSFC3B.268
*ENDIF DEF,A01_3A,OR,DEF,A02_3A TRSFC3B.269
*ENDIF DEF,A70_1B TRSFC3B.270