SUBROUTINE TWO_COEFF(IERR 8,6TCF3B.41
& , N_PROFILE, I_LAYER_FIRST, I_LAYER_LAST TCF3B.42
& , I_2STREAM, L_IR_SOURCE_QUAD TCF3B.43
& , ASYMMETRY, OMEGA, TAU TCF3B.44
& , ISOLIR, SEC_0 TCF3B.45
& , TRANS, REFLECT, TRANS_0 TCF3B.46
& , SOURCE_COEFF TCF3B.47
& , NPD_PROFILE, NPD_LAYER TCF3B.48
& ) TCF3B.49
! TCF3B.50
! TCF3B.51
! TCF3B.52
IMPLICIT NONE TCF3B.53
! TCF3B.54
! TCF3B.55
! SIZES OF DUMMY ARRAYS. TCF3B.56
INTEGER !, INTENT(IN) TCF3B.57
& NPD_PROFILE TCF3B.58
! MAXIMUM NUMBER OF PROFILES TCF3B.59
& , NPD_LAYER TCF3B.60
! MAXIMUM NUMBER OF LAYERS TCF3B.61
! TCF3B.62
! INCLUDE COMDECKS. TCF3B.63
*CALL DIMFIX3A 
TCF3B.64
*CALL SPCRG3A TCF3B.65
*CALL PRMCH3A TCF3B.66
*CALL PRECSN3A TCF3B.67
*CALL ERROR3A TCF3B.68
! TCF3B.69
! TCF3B.70
! TCF3B.71
! DUMMY ARGUMENTS. TCF3B.72
INTEGER !, INTENT(OUT) TCF3B.73
& IERR TCF3B.74
! ERROR FLAG TCF3B.75
INTEGER !, INTENT(IN) TCF3B.76
& N_PROFILE TCF3B.77
! NUMBER OF PROFILES TCF3B.78
& , I_LAYER_FIRST TCF3B.79
! FIRST LAYER TO CONSIDER TCF3B.80
& , I_LAYER_LAST TCF3B.81
! LAST LAYER TO CONSIDER TCF3B.82
& , ISOLIR TCF3B.83
! SPECTRAL REGION TCF3B.84
& , I_2STREAM TCF3B.85
! TWO STREAM SCHEME TCF3B.86
LOGICAL !, INTENT(IN) TCF3B.87
& L_IR_SOURCE_QUAD TCF3B.88
! USE A QUADRATIC SOURCE FUNCTION TCF3B.89
! TCF3B.90
! OPTICAL PROPERTIES OF LAYER: TCF3B.91
REAL !, INTENT(IN) TCF3B.92
& ASYMMETRY(NPD_PROFILE, NPD_LAYER) TCF3B.93
! ASYMMETRY FACTOR TCF3B.94
& , OMEGA(NPD_PROFILE, NPD_LAYER) TCF3B.95
! ALBEDO OF SINGLE SCATTERING TCF3B.96
& , TAU(NPD_PROFILE, NPD_LAYER) TCF3B.97
! OPTICAL DEPTH TCF3B.98
! TCF3B.99
! SOLAR BEAM TCF3B.100
REAL !, INTENT(IN) TCF3B.101
& SEC_0(NPD_PROFILE) TCF3B.102
! SECANT OF ZENITH ANGLE TCF3B.103
! TCF3B.104
! TCF3B.105
! COEFFICIENTS IN THE TWO-STREAM EQUATIONS: TCF3B.106
REAL !, INTENT(OUT) TCF3B.107
& TRANS(NPD_PROFILE, NPD_LAYER) TCF3B.108
! DIFFUSE TRANSMISSION COEFFICIENT TCF3B.109
& , REFLECT(NPD_PROFILE, NPD_LAYER) TCF3B.110
! DIFFUSE REFLECTION COEFFICIENT TCF3B.111
& , TRANS_0(NPD_PROFILE, NPD_LAYER) TCF3B.112
! DIRECT TRANSMISSION COEFFICIENT TCF3B.113
& , SOURCE_COEFF(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) TCF3B.114
! SOURCE COEFFICIENTS IN TWO-STREAM EQUATIONS TCF3B.115
! TCF3B.116
! TCF3B.117
! LOCAL VARIABLES. TCF3B.118
INTEGER TCF3B.119
& I TCF3B.120
! LOOP VARIABLE TCF3B.121
& , L TCF3B.122
! LOOP VARIABLE TCF3B.123
& , K TCF3B.124
! LOOP VARIABLE TCF3B.125
& , N_INDEX TCF3B.126
! NUMBER OF INDICES SATISFYING TEST TCF3B.127
& , INDEX(NPD_PROFILE) TCF3B.128
! INDICES OF TESTED POINTS TCF3B.129
! TCF3B.130
! COEFFICIENTS IN THE TWO-STREAM EQUATIONS: TCF3B.131
REAL TCF3B.132
& LAMBDA(NPD_PROFILE, NPD_LAYER) TCF3B.133
! COEFFICIENTS IN TWO-STREAM EQUATIONS TCF3B.134
& , SUM(NPD_PROFILE, NPD_LAYER) TCF3B.135
! SUM OF ALPHA_1 AND ALPHA_2 TCF3B.136
& , DIFF(NPD_PROFILE, NPD_LAYER) TCF3B.137
! DIFFERENCE OF ALPHA_1 AND ALPHA_2 TCF3B.138
& , GAMMA_UP(NPD_PROFILE, NPD_LAYER) TCF3B.139
! BASIC SOLAR COEFFICIENT FOR UPWARD RADIATION TCF3B.140
& , GAMMA_DOWN(NPD_PROFILE, NPD_LAYER) TCF3B.141
! BASIC SOLAR COEFFICIENT FOR DOWNWARD RADIATION TCF3B.142
! TCF3B.143
REAL TCF3B.144
& TARGET TCF3B.145
! TARGET TO SEARCH FOR TCF3B.146
TCF3B.147
REAL TCF3B.148
& TEMP(NPD_PROFILE) TCF3B.149
! TCF3B.150
! TCF3B.151
! SUBROUTINES CALLED: TCF3B.152
EXTERNAL TCF3B.153
& TWO_COEFF_BASIC, SOLAR_COEFFICIENT_BASIC TCF3B.154
& , TRANS_SOURCE_COEFF TCF3B.155
! TCF3B.156
! CRAY DIRECTIVES FOR THE WHOLE ROUTINE: TCF3B.157
! POINTS ARE NOT REPEATED IN THE INDEXING ARRAY, SO IT IS SAFE TCF3B.158
! TO VECTORIZE OVER INDIRECTLY ADDRESSED ARRAYS. TCF3B.159
Cfpp$ NODEPCHK R TCF3B.160
! TCF3B.161
! TCF3B.162
! TCF3B.163
! PERTURB THE SINGLE SCATTERING ALBEDO AWAY FROM 1 TO AVOID TCF3B.164
! LATER DIVISION BY 0. TCF3B.165
TARGET=1.0E+00-TOL_DIV TCF3B.166
DO I=I_LAYER_FIRST, I_LAYER_LAST TCF3B.167
! TCF3B.168
N_INDEX=0 TCF3B.169
DO L =1,N_PROFILE TCF3B.170
IF (OMEGA(L,I).GT.TARGET) THEN TCF3B.171
N_INDEX =N_INDEX+1 TCF3B.172
INDEX(N_INDEX)=L TCF3B.173
END IF TCF3B.174
END DO TCF3B.175
! TCF3B.176
DO K=1, N_INDEX TCF3B.177
OMEGA(INDEX(K), I)=TARGET TCF3B.178
ENDDO TCF3B.179
ENDDO TCF3B.180
! TCF3B.181
! CALCULATE THE BASIC TWO-STREAM COEFFICIENTS. TCF3B.182
CALL TWO_COEFF_BASIC(IERR TCF3B.183
& , N_PROFILE, I_LAYER_FIRST, I_LAYER_LAST TCF3B.184
& , I_2STREAM TCF3B.185
& , ASYMMETRY, OMEGA TCF3B.186
& , SUM, DIFF TCF3B.187
& , NPD_PROFILE, NPD_LAYER TCF3B.188
& ) TCF3B.189
IF (IERR.NE.I_NORMAL) THEN TCF3B.190
RETURN TCF3B.191
ENDIF TCF3B.192
! TCF3B.193
! LAMBDA IS NOW CALCULATED. TCF3B.194
*IF DEF,VECTLIB PXVECTLB.146
DO I=I_LAYER_FIRST, I_LAYER_LAST TCF3B.196
DO L=1, N_PROFILE TCF3B.197
TEMP(L)=SUM(L,I)*DIFF(L,I) TCF3B.198
ENDDO TCF3B.199
CALL SQRT_V(N_PROFILE,TEMP,LAMBDA(1,I)) TCF3B.200
ENDDO TCF3B.201
*ELSE TCF3B.202
DO I=I_LAYER_FIRST, I_LAYER_LAST TCF3B.203
DO L=1, N_PROFILE TCF3B.204
LAMBDA(L, I)=SQRT(SUM(L, I)*DIFF(L, I)) TCF3B.205
ENDDO TCF3B.206
ENDDO TCF3B.207
*ENDIF TCF3B.208
! TCF3B.209
! TCF3B.210
! CALCULATE THE BASIC COEFFICIENTS FOR THE SOLAR SOURCE TERMS. TCF3B.211
IF (ISOLIR.EQ.IP_SOLAR) THEN TCF3B.212
! LAMBDA MAY BE PERTURBED BY THIS ROUTINE TO AVOID TCF3B.213
! ILL-CONDITIONING FOR THE SINGULAR ZENITH ANGLE. TCF3B.214
CALL SOLAR_COEFFICIENT_BASIC(IERR TCF3B.215
& , N_PROFILE, I_LAYER_FIRST, I_LAYER_LAST TCF3B.216
& , OMEGA, ASYMMETRY, SEC_0 TCF3B.217
& , I_2STREAM TCF3B.218
& , SUM, DIFF, LAMBDA TCF3B.219
& , GAMMA_UP, GAMMA_DOWN TCF3B.220
& , NPD_PROFILE, NPD_LAYER TCF3B.221
& ) TCF3B.222
IF (IERR.NE.I_NORMAL) RETURN TCF3B.223
ENDIF TCF3B.224
! TCF3B.225
! TCF3B.226
! DETERMINE THE TRANSMISSION AND REFLECTION COEFFICIENTS. TCF3B.227
CALL TRANS_SOURCE_COEFF(N_PROFILE, I_LAYER_FIRST, I_LAYER_LAST TCF3B.228
& , ISOLIR, L_IR_SOURCE_QUAD TCF3B.229
& , TAU, SUM, DIFF, LAMBDA, SEC_0 TCF3B.230
& , GAMMA_UP, GAMMA_DOWN TCF3B.231
& , TRANS, REFLECT, TRANS_0, SOURCE_COEFF TCF3B.232
& , NPD_PROFILE, NPD_LAYER TCF3B.233
& ) TCF3B.234
! TCF3B.235
! TCF3B.236
! TCF3B.237
RETURN TCF3B.238
END TCF3B.239
*ENDIF DEF,A01_3A,OR,DEF,A02_3A TCF3B.240
*ENDIF DEF,A70_1B TCF3B.241