SUBROUTINE TWO_COEFF_REGION(IERR 1,4TWCFRG3A.39
& , N_PROFILE, N_LAYER, N_CLOUD_TOP TWCFRG3A.40
& , I_2STREAM, L_IR_SOURCE_QUAD, N_SOURCE_COEFF TWCFRG3A.41
& , N_CLOUD_TYPE, FRAC_CLOUD TWCFRG3A.42
& , I_REGION_CLOUD, FRAC_REGION TWCFRG3A.43
& , ASYMMETRY_FREE, OMEGA_FREE, TAU_FREE TWCFRG3A.44
& , ASYMMETRY_CLOUD, OMEGA_CLOUD, TAU_CLOUD TWCFRG3A.45
& , ISOLIR, SEC_0 TWCFRG3A.46
& , TRANS, REFLECT, TRANS_0 TWCFRG3A.47
& , SOURCE_COEFF TWCFRG3A.48
& , NPD_PROFILE, NPD_LAYER TWCFRG3A.49
& ) TWCFRG3A.50
! TWCFRG3A.51
! TWCFRG3A.52
! TWCFRG3A.53
IMPLICIT NONE TWCFRG3A.54
! TWCFRG3A.55
! TWCFRG3A.56
! SIZES OF DUMMY ARRAYS. TWCFRG3A.57
INTEGER !, INTENT(IN) TWCFRG3A.58
& NPD_PROFILE TWCFRG3A.59
! MAXIMUM NUMBER OF PROFILES TWCFRG3A.60
& , NPD_LAYER TWCFRG3A.61
! MAXIMUM NUMBER OF LAYERS TWCFRG3A.62
! TWCFRG3A.63
! INCLUDE COMDECKS. TWCFRG3A.64
*CALL DIMFIX3A 
TWCFRG3A.65
*CALL SPCRG3A TWCFRG3A.66
*CALL ERROR3A TWCFRG3A.67
*CALL CLDREG3A TWCFRG3A.68
! TWCFRG3A.69
! TWCFRG3A.70
! TWCFRG3A.71
! DUMMY ARGUMENTS. TWCFRG3A.72
INTEGER !, INTENT(OUT) TWCFRG3A.73
& IERR TWCFRG3A.74
! ERROR FLAG TWCFRG3A.75
INTEGER !, INTENT(IN) TWCFRG3A.76
& N_PROFILE TWCFRG3A.77
! NUMBER OF PROFILES TWCFRG3A.78
& , N_LAYER TWCFRG3A.79
! NUMBER OF LAYERS TWCFRG3A.80
& , N_CLOUD_TOP TWCFRG3A.81
! TOPMOST CLOUDY LAYER TWCFRG3A.82
& , ISOLIR TWCFRG3A.83
! SPECTRAL REGION TWCFRG3A.84
& , N_CLOUD_TYPE TWCFRG3A.85
! NUMBER OF TYPES OF CLOUDS TWCFRG3A.86
& , I_2STREAM TWCFRG3A.87
! TWO STREAM SCHEME TWCFRG3A.88
& , N_SOURCE_COEFF TWCFRG3A.89
! NUMBER OF SOURCE COEFFICIENTS TWCFRG3A.90
! TWCFRG3A.91
INTEGER !, INTENT(IN) TWCFRG3A.92
& I_REGION_CLOUD(NPD_CLOUD_TYPE) TWCFRG3A.93
! REGIONS IN WHICH TYPES OF CLOUDS FALL TWCFRG3A.94
! TWCFRG3A.95
LOGICAL !, INTENT(IN) TWCFRG3A.96
& L_IR_SOURCE_QUAD TWCFRG3A.97
! USE A QUADRATIC SOURCE IN THE INFRA-RED TWCFRG3A.98
! TWCFRG3A.99
! OPTICAL PROPERTIES OF LAYER: TWCFRG3A.100
REAL !, INTENT(IN) TWCFRG3A.101
& FRAC_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) TWCFRG3A.102
! FRACTIONS OF DIFFERENT TYPES OF CLOUDS TWCFRG3A.103
& , FRAC_REGION(NPD_PROFILE, NPD_LAYER, NPD_REGION) TWCFRG3A.104
! FRACTIONS OF TOTAL CLOUD OCCUPIED BY EACH REGION TWCFRG3A.105
& , ASYMMETRY_FREE(NPD_PROFILE, NPD_LAYER) ADB1F405.1001
! CLEAR-SKY ASYMMETRY FACTOR TWCFRG3A.107
& , OMEGA_FREE(NPD_PROFILE, NPD_LAYER) ADB1F405.1002
! CLEAR-SKY ALBEDO OF SINGLE SCATTERING TWCFRG3A.109
& , TAU_FREE(NPD_PROFILE, NPD_LAYER) ADB1F405.1003
! CLEAR-SKY OPTICAL DEPTH TWCFRG3A.111
& , ASYMMETRY_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) TWCFRG3A.112
! ASYMMETRY FACTOR TWCFRG3A.113
& , OMEGA_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) TWCFRG3A.114
! ALBEDO OF SINGLE SCATTERING TWCFRG3A.115
& , TAU_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE) TWCFRG3A.116
! OPTICAL DEPTH TWCFRG3A.117
! TWCFRG3A.118
! SOLAR BEAM TWCFRG3A.119
REAL !, INTENT(IN) TWCFRG3A.120
& SEC_0(NPD_PROFILE) TWCFRG3A.121
! SECANT OF ZENITH ANGLE TWCFRG3A.122
! TWCFRG3A.123
! TWCFRG3A.124
! COEFFICIENTS IN THE TWO-STREAM EQUATIONS: TWCFRG3A.125
REAL !, INTENT(OUT) TWCFRG3A.126
& TRANS(NPD_PROFILE, NPD_LAYER, NPD_REGION) TWCFRG3A.127
! DIFFUSE TRANSMISSION COEFFICIENT TWCFRG3A.128
& , REFLECT(NPD_PROFILE, NPD_LAYER, NPD_REGION) TWCFRG3A.129
! DIFFUSE REFLECTION COEFFICIENT TWCFRG3A.130
& , TRANS_0(NPD_PROFILE, NPD_LAYER, NPD_REGION) TWCFRG3A.131
! DIRECT TRANSMISSION COEFFICIENT TWCFRG3A.132
& , SOURCE_COEFF(NPD_PROFILE, NPD_LAYER TWCFRG3A.133
& , NPD_SOURCE_COEFF, NPD_REGION) TWCFRG3A.134
! SOURCE COEFFICIENTS IN TWO-STREAM EQUATIONS TWCFRG3A.135
! TWCFRG3A.136
! LOCAL VARIABLES. TWCFRG3A.137
INTEGER TWCFRG3A.138
& N_REGION TWCFRG3A.139
! NUMBER OF REGIONS TWCFRG3A.140
INTEGER TWCFRG3A.141
& I TWCFRG3A.142
! LOOP VARIABLE TWCFRG3A.143
& , J TWCFRG3A.144
! LOOP VARIABLE TWCFRG3A.145
& , K TWCFRG3A.146
! LOOP VARIABLE TWCFRG3A.147
& , L TWCFRG3A.148
! LOOP VARIABLE TWCFRG3A.149
& , I_REGION TWCFRG3A.150
! LOOP VARIABLE OVER REGIONS TWCFRG3A.151
! TWCFRG3A.152
! COEFFICIENTS IN THE TWO-STREAM EQUATIONS: TWCFRG3A.153
REAL !, INTENT(OUT) TWCFRG3A.154
& TRANS_TEMP(NPD_PROFILE, NPD_LAYER) TWCFRG3A.155
! TEMPORARY DIFFUSE TRANSMISSION COEFFICIENT TWCFRG3A.156
& , REFLECT_TEMP(NPD_PROFILE, NPD_LAYER) TWCFRG3A.157
! TEMPORARY DIFFUSE REFLECTION COEFFICIENT TWCFRG3A.158
& , TRANS_0_TEMP(NPD_PROFILE, NPD_LAYER) TWCFRG3A.159
! TEMPORARY DIRECT TRANSMISSION COEFFICIENT TWCFRG3A.160
& , SOURCE_COEFF_TEMP(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF) TWCFRG3A.161
! TEMPORARY SOURCE COEFFICIENTS IN TWO-STREAM EQUATIONS TWCFRG3A.162
! TWCFRG3A.163
! VARIABLES FOR GATHERING: TWCFRG3A.164
INTEGER TWCFRG3A.165
& N_LIST TWCFRG3A.166
! NUMBER OF POINTS IN LIST TWCFRG3A.167
& , L_LIST(NPD_PROFILE) TWCFRG3A.168
! LIST OF COLLECTED POINTS TWCFRG3A.169
& , LL TWCFRG3A.170
REAL TWCFRG3A.175
& TAU_GATHERED(NPD_PROFILE, NPD_LAYER) TWCFRG3A.176
! GATHERED OPTICAL DEPTH TWCFRG3A.177
& , OMEGA_GATHERED(NPD_PROFILE, NPD_LAYER) TWCFRG3A.178
! GATHERED ALEBDO OF SINGLE SCATTERING TWCFRG3A.179
& , ASYMMETRY_GATHERED(NPD_PROFILE, NPD_LAYER) TWCFRG3A.180
! GATHERED ASYMMETRY TWCFRG3A.181
& , SEC_0_GATHERED(NPD_PROFILE) TWCFRG3A.182
! GATHERED ASYMMETRY TWCFRG3A.183
! TWCFRG3A.184
! SUBROUTINES CALLED: TWCFRG3A.185
EXTERNAL TWCFRG3A.186
& TWO_COEFF ADB5F403.94
! TWCFRG3A.188
! CRAY DIRECTIVES FOR THE WHOLE ROUTINE: TWCFRG3A.189
! POINTS ARE NOT REPEATED IN THE INDEXING ARRAY, SO IT IS SAFE TWCFRG3A.190
! TO VECTORIZE OVER INDIRECTLY ADDRESSED ARRAYS. TWCFRG3A.191
Cfpp$ NODEPCHK R TWCFRG3A.192
! TWCFRG3A.193
! TWCFRG3A.194
! TWCFRG3A.195
! FOR THE TRIPLE OVERLAP THE NUMBER OF REGIONS IS 3. TWCFRG3A.196
N_REGION=3 TWCFRG3A.197
! TWCFRG3A.198
! DETERMINE THE OPTICAL PROPERTIES OF THE CLEAR-SKY REGIONS OF TWCFRG3A.199
! THE LAYERS. TWCFRG3A.200
! TWCFRG3A.201
CALL TWO_COEFF(IERR TWCFRG3A.202
& , N_PROFILE, 1, N_LAYER TWCFRG3A.203
& , I_2STREAM, L_IR_SOURCE_QUAD TWCFRG3A.204
& , ASYMMETRY_FREE, OMEGA_FREE, TAU_FREE TWCFRG3A.205
& , ISOLIR, SEC_0 TWCFRG3A.206
& , TRANS(1, 1, IP_REGION_CLEAR) TWCFRG3A.207
& , REFLECT(1, 1, IP_REGION_CLEAR) TWCFRG3A.208
& , TRANS_0(1, 1, IP_REGION_CLEAR) TWCFRG3A.209
& , SOURCE_COEFF(1, 1, 1, IP_REGION_CLEAR) TWCFRG3A.210
& , NPD_PROFILE, NPD_LAYER TWCFRG3A.211
& ) TWCFRG3A.212
IF (IERR.NE.I_NORMAL) RETURN TWCFRG3A.213
! TWCFRG3A.214
! TWCFRG3A.215
! NOW DEAL WITH CLOUDS. TWCFRG3A.216
! TWCFRG3A.217
! INITIALIZE THE FULL ARRAYS FOR CLOUDY REGIONS. TWCFRG3A.218
! TWCFRG3A.219
DO I_REGION=1, N_REGION TWCFRG3A.220
IF (I_REGION.NE.IP_REGION_CLEAR) THEN TWCFRG3A.221
DO I=N_CLOUD_TOP, N_LAYER TWCFRG3A.222
DO L=1, N_PROFILE TWCFRG3A.223
TRANS(L, I, I_REGION)=0.0E+00 TWCFRG3A.224
REFLECT(L, I, I_REGION)=0.0E+00 TWCFRG3A.225
ENDDO TWCFRG3A.226
ENDDO TWCFRG3A.227
DO J=1, N_SOURCE_COEFF TWCFRG3A.228
DO I=N_CLOUD_TOP, N_LAYER TWCFRG3A.229
DO L=1, N_PROFILE TWCFRG3A.230
SOURCE_COEFF(L, I, J, I_REGION)=0.0E+00 TWCFRG3A.231
ENDDO TWCFRG3A.232
ENDDO TWCFRG3A.233
ENDDO TWCFRG3A.234
! TWCFRG3A.235
IF (ISOLIR.EQ.IP_SOLAR) THEN TWCFRG3A.236
DO I=N_CLOUD_TOP, N_LAYER TWCFRG3A.237
DO L=1, N_PROFILE TWCFRG3A.238
TRANS_0(L, I, I_REGION)=0.0E+00 TWCFRG3A.239
ENDDO TWCFRG3A.240
ENDDO TWCFRG3A.241
ENDIF TWCFRG3A.242
! TWCFRG3A.243
ENDIF TWCFRG3A.244
! TWCFRG3A.245
ENDDO TWCFRG3A.246
! TWCFRG3A.247
! TWCFRG3A.248
! TWCFRG3A.249
! CONSIDER EACH TYPE OF CLOUD IN TURN, CHECKING WHICH REGION IT TWCFRG3A.250
! CONTRUBUTES TO AND FORM WEIGHTED SUMS OF CLOUD PROPERTIES. TWCFRG3A.251
! TWCFRG3A.252
DO K=1, N_CLOUD_TYPE TWCFRG3A.253
! TWCFRG3A.254
! TWCFRG3A.255
! SET THE REGION IN WHICH CLOUDS OF THIS TYPE ARE INCLUDED. TWCFRG3A.256
I_REGION=I_REGION_CLOUD(K) TWCFRG3A.257
! TWCFRG3A.258
DO I=N_CLOUD_TOP, N_LAYER TWCFRG3A.262
! TWCFRG3A.263
! FORM A LIST OF POINTS WHERE CLOUD OF THIS TYPE EXISTS ADB5F403.95
! ON THIS ROW FOR GATHERING. ADB5F403.96
N_LIST=0 ADB5F403.97
DO L=1, N_PROFILE ADB5F403.98
IF (FRAC_CLOUD(L, I, K).GT.0.0E+00) THEN ADB5F403.99
N_LIST=N_LIST+1 ADB5F403.100
L_LIST(N_LIST)=L ADB5F403.101
ENDIF ADB5F403.102
ENDDO ADB5F403.103
! TWCFRG3A.267
! TWCFRG3A.268
IF (N_LIST.GT.0) THEN TWCFRG3A.269
! TWCFRG3A.270
! GATHER THE OPTICAL PROPERTIES. THOUGH WE CONSIDER ONLY TWCFRG3A.271
! ONE LAYER AT A TIME THE LOWER ROUTINES WILL OPERATE ON TWCFRG3A.272
! ARRAYS WITH VERTICAL STRUCTURE, SO THE GATHERED ARRAYS TWCFRG3A.273
! ARE TWO-DIMENSIONAL. TWCFRG3A.274
! TWCFRG3A.275
DO L=1, N_LIST TWCFRG3A.276
TAU_GATHERED(L, I) TWCFRG3A.277
& =TAU_CLOUD(L_LIST(L), I, K) TWCFRG3A.278
OMEGA_GATHERED(L, I) TWCFRG3A.279
& =OMEGA_CLOUD(L_LIST(L), I, K) TWCFRG3A.280
ASYMMETRY_GATHERED(L, I) TWCFRG3A.281
& =ASYMMETRY_CLOUD(L_LIST(L), I, K) TWCFRG3A.282
ENDDO TWCFRG3A.283
IF (ISOLIR.EQ.IP_SOLAR) THEN TWCFRG3A.284
DO L=1, N_LIST TWCFRG3A.285
SEC_0_GATHERED(L)=SEC_0(L_LIST(L)) TWCFRG3A.286
ENDDO TWCFRG3A.287
ENDIF TWCFRG3A.288
! TWCFRG3A.289
! TWCFRG3A.290
CALL TWO_COEFF(IERR TWCFRG3A.291
& , N_LIST, I, I TWCFRG3A.292
& , I_2STREAM, L_IR_SOURCE_QUAD TWCFRG3A.293
& , ASYMMETRY_GATHERED, OMEGA_GATHERED TWCFRG3A.294
& , TAU_GATHERED TWCFRG3A.295
& , ISOLIR, SEC_0_GATHERED TWCFRG3A.296
& , TRANS_TEMP, REFLECT_TEMP, TRANS_0_TEMP TWCFRG3A.297
& , SOURCE_COEFF_TEMP TWCFRG3A.298
& , NPD_PROFILE, NPD_LAYER TWCFRG3A.299
& ) TWCFRG3A.300
IF (IERR.NE.I_NORMAL) RETURN TWCFRG3A.301
! TWCFRG3A.302
! TWCFRG3A.303
DO L=1, N_LIST TWCFRG3A.304
LL=L_LIST(L) TWCFRG3A.305
TRANS(LL, I, I_REGION)=TRANS(LL, I, I_REGION) TWCFRG3A.306
& +FRAC_CLOUD(LL, I, K)*TRANS_TEMP(L, I) TWCFRG3A.307
REFLECT(LL, I, I_REGION)=REFLECT(LL, I, I_REGION) TWCFRG3A.308
& +FRAC_CLOUD(LL, I, K)*REFLECT_TEMP(L, I) TWCFRG3A.309
ENDDO TWCFRG3A.310
DO J=1, N_SOURCE_COEFF TWCFRG3A.311
DO L=1, N_LIST TWCFRG3A.312
LL=L_LIST(L) TWCFRG3A.313
SOURCE_COEFF(LL, I, J, I_REGION) TWCFRG3A.314
& =SOURCE_COEFF(LL, I, J, I_REGION) TWCFRG3A.315
& +FRAC_CLOUD(LL, I, K) TWCFRG3A.316
& *SOURCE_COEFF_TEMP(L, I, J) TWCFRG3A.317
ENDDO TWCFRG3A.318
ENDDO TWCFRG3A.319
IF (ISOLIR.EQ.IP_SOLAR) THEN TWCFRG3A.320
DO L=1, N_LIST TWCFRG3A.321
LL=L_LIST(L) TWCFRG3A.322
TRANS_0(LL, I, I_REGION)=TRANS_0(LL, I, I_REGION) TWCFRG3A.323
& +FRAC_CLOUD(LL, I, K)*TRANS_0_TEMP(L, I) TWCFRG3A.324
ENDDO TWCFRG3A.325
ENDIF TWCFRG3A.326
! TWCFRG3A.327
ENDIF TWCFRG3A.328
! TWCFRG3A.329
ENDDO TWCFRG3A.330
ENDDO TWCFRG3A.331
! TWCFRG3A.332
! ADB5F403.104
! FINALLY, SCALE THE WEIGHTED SUMS BY THE CLOUD FRACTIONS. TWCFRG3A.333
DO I_REGION=1, N_REGION TWCFRG3A.334
IF (I_REGION.NE.IP_REGION_CLEAR) THEN TWCFRG3A.335
DO I=N_CLOUD_TOP, N_LAYER TWCFRG3A.336
! ADB5F403.105
! GATHER POINTS WITHIN THIS REGION. ADB5F403.106
N_LIST=0 ADB5F403.107
DO L=1,N_PROFILE ADB5F403.108
IF (FRAC_REGION(L, I, I_REGION).GT.0.0E+00) THEN ADB5F403.109
N_LIST=N_LIST+1 ADB5F403.110
L_LIST(N_LIST)=L ADB5F403.111
ENDIF ADB5F403.112
ENDDO ADB5F403.113
DO L=1, N_LIST TWCFRG3A.339
LL=L_LIST(L) TWCFRG3A.340
TRANS(LL, I, I_REGION)=TRANS(LL, I, I_REGION) TWCFRG3A.341
& /FRAC_REGION(LL, I, I_REGION) TWCFRG3A.342
REFLECT(LL, I, I_REGION)=REFLECT(LL, I, I_REGION) TWCFRG3A.343
& /FRAC_REGION(LL, I, I_REGION) TWCFRG3A.344
ENDDO TWCFRG3A.345
DO J=1, N_SOURCE_COEFF TWCFRG3A.346
DO L=1, N_LIST TWCFRG3A.347
LL=L_LIST(L) TWCFRG3A.348
SOURCE_COEFF(LL, I, J, I_REGION) TWCFRG3A.349
& =SOURCE_COEFF(LL, I, J, I_REGION) TWCFRG3A.350
& /FRAC_REGION(LL, I, I_REGION) TWCFRG3A.351
ENDDO TWCFRG3A.352
ENDDO TWCFRG3A.353
IF (ISOLIR.EQ.IP_SOLAR) THEN TWCFRG3A.354
DO L=1, N_LIST TWCFRG3A.355
LL=L_LIST(L) TWCFRG3A.356
TRANS_0(LL, I, I_REGION)=TRANS_0(LL, I, I_REGION) TWCFRG3A.357
& /FRAC_REGION(LL, I, I_REGION) TWCFRG3A.358
ENDDO TWCFRG3A.359
ENDIF TWCFRG3A.360
ENDDO TWCFRG3A.361
ENDIF TWCFRG3A.362
ENDDO TWCFRG3A.363
! TWCFRG3A.364
! TWCFRG3A.365
! TWCFRG3A.366
RETURN TWCFRG3A.367
END TWCFRG3A.368
*ENDIF DEF,A01_3A,OR,DEF,A02_3A TWCFRG3A.369
*ENDIF DEF,A70_1A TWCFRG3A.370