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