*IF DEF,A70_1A,OR,DEF,A70_1B                                               APB4F405.121    
*IF DEF,A01_3A,OR,DEF,A02_3A                                               TCFC3A.2      
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.    GTS2F400.14198  
C                                                                          GTS2F400.14199  
C Use, duplication or disclosure of this code is subject to the            GTS2F400.14200  
C restrictions as set forth in the contract.                               GTS2F400.14201  
C                                                                          GTS2F400.14202  
C                Meteorological Office                                     GTS2F400.14203  
C                London Road                                               GTS2F400.14204  
C                BRACKNELL                                                 GTS2F400.14205  
C                Berkshire UK                                              GTS2F400.14206  
C                RG12 2SZ                                                  GTS2F400.14207  
C                                                                          GTS2F400.14208  
C If no contract has been raised with this copy of the code, the use,      GTS2F400.14209  
C duplication or disclosure of it is strictly prohibited.  Permission      GTS2F400.14210  
C to do so must first be obtained in writing from the Head of Numerical    GTS2F400.14211  
C Modelling at the above address.                                          GTS2F400.14212  
C ******************************COPYRIGHT******************************    GTS2F400.14213  
C                                                                          GTS2F400.14214  
!+ Subroutine to calculate cloudy two-stream coefficients.                 TCFC3A.3      
!                                                                          TCFC3A.4      
! Method:                                                                  TCFC3A.5      
!       The coeffients for each type of cloud are determined and           TCFC3A.6      
!       averaged.                                                          TCFC3A.7      
!                                                                          TCFC3A.8      
! Current Owner of Code: J. M. Edwards                                     TCFC3A.9      
!                                                                          TCFC3A.10     
! History:                                                                 TCFC3A.11     
!       Version         Date                    Comment                    TCFC3A.12     
!       4.0             27-07-95                Original Code              TCFC3A.13     
!                                               (J. M. Edwards)            TCFC3A.14     
!       4.1             04-03-96                Gathering and scattering   ADB1F401.1131   
!                                               of types of clouds         ADB1F401.1132   
!                                               introduced for speed.      ADB1F401.1133   
!                                               This change has no         ADB1F401.1134   
!                                               physical effect.           ADB1F401.1135   
!       4.2             Nov. 96   T3E migration: CALL WHENFGT replaced     GSS2F402.51     
!                                  by portable fortran code.               GSS2F402.52     
!                                                S.J.Swarbrick             GSS2F402.53     
!LL  4.5  27/04/98  Add Fujitsu vectorization directive.                   GRB0F405.160    
!LL                                           RBarnes@ecmwf.int            GRB0F405.161    
!                                                                          TCFC3A.15     
! Description of Code:                                                     TCFC3A.16     
!   FORTRAN 77  with extensions listed in documentation.                   TCFC3A.17     
!                                                                          TCFC3A.18     
!- ---------------------------------------------------------------------   TCFC3A.19     
! Fujitsu directive to encourage vectorization for whole routine           GRB0F405.162    
!OCL NOVREC                                                                GRB0F405.163    

      SUBROUTINE TWO_COEFF_CLOUD(IERR                                       2,1TCFC3A.20     
     &   , N_PROFILE, I_LAYER_FIRST, I_LAYER_LAST                          TCFC3A.21     
     &   , I_2STREAM, L_IR_SOURCE_QUAD, N_SOURCE_COEFF                     TCFC3A.22     
     &   , N_CLOUD_TYPE, FRAC_CLOUD                                        TCFC3A.23     
     &   , ASYMMETRY_CLOUD, OMEGA_CLOUD, TAU_CLOUD                         TCFC3A.24     
     &   , ISOLIR, SEC_0                                                   TCFC3A.25     
     &   , TRANS_CLOUD, REFLECT_CLOUD, TRANS_0_CLOUD                       TCFC3A.26     
     &   , SOURCE_COEFF_CLOUD                                              TCFC3A.27     
     &   , NPD_PROFILE, NPD_LAYER                                          TCFC3A.28     
     &   )                                                                 TCFC3A.29     
!                                                                          TCFC3A.30     
!                                                                          TCFC3A.31     
!                                                                          TCFC3A.32     
      IMPLICIT NONE                                                        TCFC3A.33     
!                                                                          TCFC3A.34     
!                                                                          TCFC3A.35     
!     SIZES OF DUMMY ARRAYS.                                               TCFC3A.36     
      INTEGER   !, INTENT(IN)                                              TCFC3A.37     
     &     NPD_PROFILE                                                     TCFC3A.38     
!             MAXIMUM NUMBER OF PROFILES                                   TCFC3A.39     
     &   , NPD_LAYER                                                       TCFC3A.40     
!             MAXIMUM NUMBER OF LAYERS                                     TCFC3A.41     
!                                                                          TCFC3A.42     
!     INCLUDE COMDECKS.                                                    TCFC3A.43     
*CALL DIMFIX3A                                                             TCFC3A.44     
*CALL SPCRG3A                                                              TCFC3A.45     
*CALL ERROR3A                                                              TCFC3A.46     
!                                                                          TCFC3A.47     
!                                                                          TCFC3A.48     
!                                                                          TCFC3A.49     
!     DUMMY ARGUMENTS.                                                     TCFC3A.50     
      INTEGER   !, INTENT(OUT)                                             TCFC3A.51     
     &     IERR                                                            TCFC3A.52     
!             ERROR FLAG                                                   TCFC3A.53     
      INTEGER   !, INTENT(IN)                                              TCFC3A.54     
     &     N_PROFILE                                                       TCFC3A.55     
!             NUMBER OF PROFILES                                           TCFC3A.56     
     &   , I_LAYER_FIRST                                                   TCFC3A.57     
!             FIRST LAYER TO CONSIDER                                      TCFC3A.58     
     &   , I_LAYER_LAST                                                    TCFC3A.59     
!             LAST LAYER TO CONSIDER                                       TCFC3A.60     
     &   , ISOLIR                                                          TCFC3A.61     
!             SPECTRAL REGION                                              TCFC3A.62     
     &   , N_CLOUD_TYPE                                                    TCFC3A.63     
!             NUMBER OF TYPES OF CLOUDS                                    TCFC3A.64     
     &   , I_2STREAM                                                       TCFC3A.65     
!             TWO STREAM SCHEME                                            TCFC3A.66     
     &   , N_SOURCE_COEFF                                                  TCFC3A.67     
!             NUMBER OF SOURCE COEFFICIENTS                                TCFC3A.68     
!                                                                          ADB1F401.1136   
      LOGICAL   !, INTENT(IN)                                              TCFC3A.69     
     &     L_IR_SOURCE_QUAD                                                TCFC3A.70     
!             USE A QUADRATIC SOURCE IN THE INFRA-RED                      TCFC3A.71     
!                                                                          TCFC3A.72     
!     OPTICAL PROPERTIES OF LAYER:                                         TCFC3A.73     
      REAL      !, INTENT(IN)                                              TCFC3A.74     
     &     FRAC_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE)              TCFC3A.75     
!             FRACTIONS OF DIFFERENT TYPES OF CLOUDS                       TCFC3A.76     
     &   , ASYMMETRY_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE)         TCFC3A.77     
!             ASYMMETRY FACTOR                                             TCFC3A.78     
     &   , OMEGA_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE)             TCFC3A.79     
!             ALBEDO OF SINGLE SCATTERING                                  TCFC3A.80     
     &   , TAU_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE)               TCFC3A.81     
!             OPTICAL DEPTH                                                TCFC3A.82     
!                                                                          TCFC3A.83     
!     SOLAR BEAM                                                           TCFC3A.84     
      REAL      !, INTENT(IN)                                              TCFC3A.85     
     &     SEC_0(NPD_PROFILE)                                              TCFC3A.86     
!             SECANT OF ZENITH ANGLE                                       TCFC3A.87     
!                                                                          TCFC3A.88     
!                                                                          TCFC3A.89     
!     COEFFICIENTS IN THE TWO-STREAM EQUATIONS:                            TCFC3A.90     
      REAL      !, INTENT(OUT)                                             TCFC3A.91     
     &     TRANS_CLOUD(NPD_PROFILE, NPD_LAYER)                             TCFC3A.92     
!             MEAN DIFFUSE TRANSMISSION COEFFICIENT                        TCFC3A.93     
     &   , REFLECT_CLOUD(NPD_PROFILE, NPD_LAYER)                           TCFC3A.94     
!             MEAN DIFFUSE REFLECTION COEFFICIENT                          TCFC3A.95     
     &   , TRANS_0_CLOUD(NPD_PROFILE, NPD_LAYER)                           TCFC3A.96     
!             MEAN DIRECT TRANSMISSION COEFFICIENT                         TCFC3A.97     
     &   , SOURCE_COEFF_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF)    TCFC3A.98     
!             MEAN SOURCE COEFFICIENTS IN TWO-STREAM EQUATIONS             TCFC3A.99     
!                                                                          TCFC3A.100    
!     LOCAL VARIABLES.                                                     TCFC3A.101    
      INTEGER                                                              TCFC3A.102    
     &     I                                                               TCFC3A.103    
!             LOOP VARIABLE                                                TCFC3A.104    
     &   , J                                                               TCFC3A.105    
!             LOOP VARIABLE                                                TCFC3A.106    
     &   , K                                                               TCFC3A.107    
!             LOOP VARIABLE                                                TCFC3A.108    
     &   , L                                                               TCFC3A.109    
!             LOOP VARIABLE                                                TCFC3A.110    
!                                                                          TCFC3A.111    
!     COEFFICIENTS IN THE TWO-STREAM EQUATIONS:                            TCFC3A.112    
      REAL      !, INTENT(OUT)                                             TCFC3A.113    
     &     TRANS_TEMP(NPD_PROFILE, NPD_LAYER)                              TCFC3A.114    
!             TEMPORARY DIFFUSE TRANSMISSION COEFFICIENT                   TCFC3A.115    
     &   , REFLECT_TEMP(NPD_PROFILE, NPD_LAYER)                            TCFC3A.116    
!             TEMPORARY DIFFUSE REFLECTION COEFFICIENT                     TCFC3A.117    
     &   , TRANS_0_TEMP(NPD_PROFILE, NPD_LAYER)                            TCFC3A.118    
!             TEMPORARY DIRECT TRANSMISSION COEFFICIENT                    TCFC3A.119    
     &   , SOURCE_COEFF_TEMP(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF)     TCFC3A.120    
!             TEMPORARY SOURCE COEFFICIENTS IN TWO-STREAM EQUATIONS        TCFC3A.121    
!                                                                          TCFC3A.122    
!     VARIABLES FOR GATHERING:                                             ADB1F401.1137   
      INTEGER                                                              ADB1F401.1138   
     &     N_LIST                                                          ADB1F401.1139   
!             NUMBER OF POINTS IN LIST                                     ADB1F401.1140   
     &   , L_LIST(NPD_PROFILE)                                             ADB1F401.1141   
!             LIST OF COLLECTED POINTS                                     ADB1F401.1142   
     &   , LL                                                              ADB1F401.1143   
!             LOOP VARIABLE                                                ADB1F401.1144   
      REAL                                                                 ADB1F401.1145   
     &     TARGET                                                          ADB1F401.1146   
!             TARGET FOR SEARCHING                                         ADB1F401.1147   
      REAL                                                                 ADB1F401.1148   
     &     TAU_GATHERED(NPD_PROFILE, NPD_LAYER)                            ADB1F401.1149   
!             GATHERED OPTICAL DEPTH                                       ADB1F401.1150   
     &   , OMEGA_GATHERED(NPD_PROFILE, NPD_LAYER)                          ADB1F401.1151   
!             GATHERED ALEBDO OF SINGLE SCATTERING                         ADB1F401.1152   
     &   , ASYMMETRY_GATHERED(NPD_PROFILE, NPD_LAYER)                      ADB1F401.1153   
!             GATHERED ASYMMETRY                                           ADB1F401.1154   
     &   , SEC_0_GATHERED(NPD_PROFILE)                                     ADB1F401.1155   
!             GATHERED ASYMMETRY                                           ADB1F401.1156   
!                                                                          ADB1F401.1157   
!     SUBROUTINES CALLED:                                                  TCFC3A.123    
      EXTERNAL                                                             TCFC3A.124    
     &     TWO_COEFF                                                       GSS1F403.56     
!                                                                          TCFC3A.126    
!     CRAY DIRECTIVES FOR THE WHOLE ROUTINE:                               ADB1F402.766    
!     POINTS ARE NOT REPEATED IN THE INDEXING ARRAY, SO IT IS SAFE         ADB1F402.767    
!     TO VECTORIZE OVER INDIRECTLY ADDRESSED ARRAYS.                       ADB1F402.768    
Cfpp$ NODEPCHK R                                                           ADB1F402.769    
!                                                                          TCFC3A.127    
!                                                                          TCFC3A.128    
!                                                                          TCFC3A.129    
!     INITIALIZE THE FULL ARRAYS.                                          TCFC3A.130    
!                                                                          TCFC3A.131    
      DO I=I_LAYER_FIRST, I_LAYER_LAST                                     TCFC3A.132    
         DO L=1, N_PROFILE                                                 TCFC3A.133    
            TRANS_CLOUD(L, I)=0.0E+00                                      TCFC3A.134    
            REFLECT_CLOUD(L, I)=0.0E+00                                    TCFC3A.135    
         ENDDO                                                             TCFC3A.136    
      ENDDO                                                                TCFC3A.137    
      DO J=1, N_SOURCE_COEFF                                               TCFC3A.138    
         DO I=I_LAYER_FIRST, I_LAYER_LAST                                  TCFC3A.139    
            DO L=1, N_PROFILE                                              TCFC3A.140    
               SOURCE_COEFF_CLOUD(L, I, J)=0.0E+00                         TCFC3A.141    
            ENDDO                                                          TCFC3A.142    
         ENDDO                                                             TCFC3A.143    
      ENDDO                                                                TCFC3A.144    
!                                                                          TCFC3A.145    
      IF (ISOLIR.EQ.IP_SOLAR) THEN                                         TCFC3A.146    
         DO I=I_LAYER_FIRST, I_LAYER_LAST                                  TCFC3A.147    
            DO L=1, N_PROFILE                                              TCFC3A.148    
               TRANS_0_CLOUD(L, I)=0.0E+00                                 TCFC3A.149    
            ENDDO                                                          TCFC3A.150    
         ENDDO                                                             TCFC3A.151    
      ENDIF                                                                TCFC3A.152    
!                                                                          TCFC3A.153    
!                                                                          TCFC3A.154    
!     CALCULATE THE TRANSMISSION AND REFLECTION COEFFICIENTS FOR           TCFC3A.155    
!     EACH TYPE OF CLOUD AND INCREMENT THE TOTALS, WEIGHTING WITH          TCFC3A.156    
!     THE CLOUD FRACTION.                                                  TCFC3A.157    
!                                                                          TCFC3A.158    
      DO K=1, N_CLOUD_TYPE                                                 TCFC3A.159    
!                                                                          TCFC3A.160    
!        GATHER POINTS WHERE THERE IS CLOUD OF THE PRESENT TYPE.           ADB1F401.1159   
         TARGET=0.0E+00                                                    ADB1F401.1160   
!                                                                          TCFC3A.172    
         DO I=I_LAYER_FIRST, I_LAYER_LAST                                  TCFC3A.173    
!                                                                          ADB1F401.1161   
!           DETERMINE WHETHER THIS TYPE OF CLOUD EXISTS IN THIS ROW.       ADB1F401.1162   
!                                                                          ADB1F401.1165   
            N_LIST =0                                                      GSS2F402.56     
            DO L   =1,N_PROFILE                                            GSS2F402.57     
              IF (FRAC_CLOUD(L,I,K).GT.TARGET) THEN                        GSS2F402.58     
                N_LIST   =N_LIST+1                                         GSS2F402.59     
                L_LIST(N_LIST)=L                                           GSS2F402.60     
              END IF                                                       GSS2F402.61     
            END DO                                                         GSS2F402.62     
!                                                                          ADB1F401.1166   
            IF (N_LIST.GT.0) THEN                                          ADB1F401.1167   
!                                                                          ADB1F401.1168   
!              GATHER THE OPTICAL PROPERTIES. THOUGH WE CONSIDER ONLY      ADB1F401.1169   
!              ONE LAYER AT A TIME THE LOWER ROUTINES WILL OPERATE ON      ADB1F401.1170   
!              ARRAYS WITH VERTICAL STRUCTURE, SO THE GATHERED ARRAYS      ADB1F401.1171   
!              ARE TWO-DIMENSIONAL.                                        ADB1F401.1172   
!                                                                          ADB1F401.1173   
               DO L=1, N_LIST                                              ADB1F401.1174   
                  TAU_GATHERED(L, I)                                       ADB1F401.1175   
     &              =TAU_CLOUD(L_LIST(L), I, K)                            ADB1F401.1176   
                  OMEGA_GATHERED(L, I)                                     ADB1F401.1177   
     &              =OMEGA_CLOUD(L_LIST(L), I, K)                          ADB1F401.1178   
                  ASYMMETRY_GATHERED(L, I)                                 ADB1F401.1179   
     &              =ASYMMETRY_CLOUD(L_LIST(L), I, K)                      ADB1F401.1180   
               ENDDO                                                       ADB1F401.1181   
               IF (ISOLIR.EQ.IP_SOLAR) THEN                                ADB1F401.1182   
                  DO L=1, N_LIST                                           ADB1F401.1183   
                     SEC_0_GATHERED(L)=SEC_0(L_LIST(L))                    ADB1F401.1184   
                  ENDDO                                                    ADB1F401.1185   
               ENDIF                                                       ADB1F401.1186   
!                                                                          ADB1F401.1187   
!                                                                          ADB1F401.1188   
               CALL TWO_COEFF(IERR                                         ADB1F401.1189   
     &            , N_LIST, I, I                                           ADB1F401.1190   
     &            , I_2STREAM, L_IR_SOURCE_QUAD                            ADB1F401.1191   
     &            , ASYMMETRY_GATHERED, OMEGA_GATHERED                     ADB1F401.1192   
     &            , TAU_GATHERED                                           ADB1F401.1193   
     &            , ISOLIR, SEC_0_GATHERED                                 ADB1F401.1194   
     &            , TRANS_TEMP, REFLECT_TEMP, TRANS_0_TEMP                 ADB1F401.1195   
     &            , SOURCE_COEFF_TEMP                                      ADB1F401.1196   
     &            , NPD_PROFILE, NPD_LAYER                                 ADB1F401.1197   
     &            )                                                        ADB1F401.1198   
               IF (IERR.NE.I_NORMAL) RETURN                                ADB1F401.1199   
!                                                                          ADB1F401.1200   
               DO L=1, N_LIST                                              ADB1F401.1201   
                  LL=L_LIST(L)                                             ADB1F401.1202   
                  TRANS_CLOUD(LL, I)=TRANS_CLOUD(LL, I)                    ADB1F401.1203   
     &               +FRAC_CLOUD(LL, I, K)*TRANS_TEMP(L, I)                ADB1F401.1204   
                  REFLECT_CLOUD(LL, I)=REFLECT_CLOUD(LL, I)                ADB1F401.1205   
     &               +FRAC_CLOUD(LL, I, K)*REFLECT_TEMP(L, I)              ADB1F401.1206   
               ENDDO                                                       ADB1F401.1207   
               DO J=1, N_SOURCE_COEFF                                      ADB1F401.1208   
                  DO L=1, N_LIST                                           ADB1F401.1209   
                     LL=L_LIST(L)                                          ADB1F401.1210   
                     SOURCE_COEFF_CLOUD(LL, I, J)                          ADB1F401.1211   
     &                  =SOURCE_COEFF_CLOUD(LL, I, J)                      ADB1F401.1212   
     &                  +FRAC_CLOUD(LL, I, K)*SOURCE_COEFF_TEMP(L, I, J)   ADB1F401.1213   
                  ENDDO                                                    ADB1F401.1214   
               ENDDO                                                       ADB1F401.1215   
               IF (ISOLIR.EQ.IP_SOLAR) THEN                                ADB1F401.1216   
                  DO L=1, N_LIST                                           ADB1F401.1217   
                     LL=L_LIST(L)                                          ADB1F401.1218   
                     TRANS_0_CLOUD(LL, I)=TRANS_0_CLOUD(LL, I)             ADB1F401.1219   
     &                  +FRAC_CLOUD(LL, I, K)*TRANS_0_TEMP(L, I)           ADB1F401.1220   
                  ENDDO                                                    ADB1F401.1221   
               ENDIF                                                       ADB1F401.1222   
            ENDIF                                                          ADB1F401.1223   
!                                                                          ADB1F401.1224   
         ENDDO                                                             TCFC3A.180    
      ENDDO                                                                TCFC3A.198    
!                                                                          TCFC3A.199    
!                                                                          TCFC3A.200    
!                                                                          TCFC3A.201    
      RETURN                                                               TCFC3A.202    
      END                                                                  TCFC3A.203    
*ENDIF DEF,A01_3A,OR,DEF,A02_3A                                            TCFC3A.204    
*ENDIF DEF,A70_1A,OR,DEF,A70_1B                                            APB4F405.122