*IF DEF,A70_1A,OR,DEF,A70_1B                                               APB4F405.127    
*IF DEF,A01_3A,OR,DEF,A02_3A                                               TRPSSR3A.3      
C *****************************COPYRIGHT******************************     TRPSSR3A.4      
C (c) CROWN COPYRIGHT 1996, METEOROLOGICAL OFFICE, All Rights Reserved.    TRPSSR3A.5      
C                                                                          TRPSSR3A.6      
C Use, duplication or disclosure of this code is subject to the            TRPSSR3A.7      
C restrictions as set forth in the contract.                               TRPSSR3A.8      
C                                                                          TRPSSR3A.9      
C                Meteorological Office                                     TRPSSR3A.10     
C                London Road                                               TRPSSR3A.11     
C                BRACKNELL                                                 TRPSSR3A.12     
C                Berkshire UK                                              TRPSSR3A.13     
C                RG12 2SZ                                                  TRPSSR3A.14     
C                                                                          TRPSSR3A.15     
C If no contract has been raised with this copy of the code, the use,      TRPSSR3A.16     
C duplication or disclosure of it is strictly prohibited.  Permission      TRPSSR3A.17     
C to do so must first be obtained in writing from the Head of Numerical    TRPSSR3A.18     
C Modelling at the above address.                                          TRPSSR3A.19     
C ******************************COPYRIGHT******************************    TRPSSR3A.20     
C                                                                          TRPSSR3A.21     
!+ Subroutine to set the solar solar terms in a triple column.             TRPSSR3A.22     
!                                                                          TRPSSR3A.23     
! Method:                                                                  TRPSSR3A.24     
!       The Direct beam is calculated by propagating down through          TRPSSR3A.25     
!       the column. These direct fluxes are used to  the                   TRPSSR3A.26     
!       source terms in each layer.                                        TRPSSR3A.27     
!                                                                          TRPSSR3A.28     
! Current Owner of Code: J. M. Edwards                                     TRPSSR3A.29     
!                                                                          TRPSSR3A.30     
! History:                                                                 TRPSSR3A.31     
!       Version         Date                    Comment                    TRPSSR3A.32     
!       4.2             24-05-96                Original Code              TRPSSR3A.33     
!                                               (J. M. Edwards)            TRPSSR3A.34     
!                                                                          TRPSSR3A.35     
! Description of Code:                                                     TRPSSR3A.36     
!   FORTRAN 77  with extensions listed in documentation.                   TRPSSR3A.37     
!                                                                          TRPSSR3A.38     
!- ---------------------------------------------------------------------   TRPSSR3A.39     

      SUBROUTINE TRIPLE_SOLAR_SOURCE(N_PROFILE, N_LAYER, N_CLOUD_TOP        1TRPSSR3A.40     
     &   , FLUX_INC_DIRECT                                                 TRPSSR3A.41     
     &   , L_SCALE_SOLAR, ADJUST_SOLAR_KE                                  TRPSSR3A.42     
     &   , TRANS_0, SOURCE_COEFF                                           TRPSSR3A.43     
     &   , V11, V12, V13, V21, V22, V23, V31, V32, V33                     TRPSSR3A.44     
     &   , FLUX_DIRECT                                                     TRPSSR3A.45     
     &   , FLUX_DIRECT_GROUND                                              TRPSSR3A.46     
     &   , S_UP, S_DOWN                                                    TRPSSR3A.47     
     &   , NPD_PROFILE, NPD_LAYER                                          TRPSSR3A.48     
     &   )                                                                 TRPSSR3A.49     
!                                                                          TRPSSR3A.50     
!                                                                          TRPSSR3A.51     
!                                                                          TRPSSR3A.52     
      IMPLICIT NONE                                                        TRPSSR3A.53     
!                                                                          TRPSSR3A.54     
!                                                                          TRPSSR3A.55     
!     SIZES OF DUMMY ARRAYS                                                TRPSSR3A.56     
      INTEGER   !, INTENT(IN)                                              TRPSSR3A.57     
     &     NPD_PROFILE                                                     TRPSSR3A.58     
!             MAXIMUM NUMBER OF PROFILES                                   TRPSSR3A.59     
     &   , NPD_LAYER                                                       TRPSSR3A.60     
!             MAXIMUM NUMBER OF LAYERS                                     TRPSSR3A.61     
!                                                                          TRPSSR3A.62     
!     COMDECKS INCLUDED                                                    TRPSSR3A.63     
*CALL DIMFIX3A                                                             TRPSSR3A.64     
*CALL SCFPT3A                                                              TRPSSR3A.65     
*CALL CLDREG3A                                                             TRPSSR3A.66     
!                                                                          TRPSSR3A.67     
!                                                                          TRPSSR3A.68     
!                                                                          TRPSSR3A.69     
!     DUMMY ARGUMENTS.                                                     TRPSSR3A.70     
      INTEGER   !, INTENT(IN)                                              TRPSSR3A.71     
     &     N_PROFILE                                                       TRPSSR3A.72     
!             NUMBER OF PROFILES                                           TRPSSR3A.73     
     &   , N_LAYER                                                         TRPSSR3A.74     
!             NUMBER OF LAYERS                                             TRPSSR3A.75     
     &   , N_CLOUD_TOP                                                     TRPSSR3A.76     
!             TOP CLOUDY LAYER                                             TRPSSR3A.77     
!                                                                          TRPSSR3A.78     
!     SPECIAL ARRAYS FOR EQUIVALENT EXTINCTION:                            TRPSSR3A.79     
      LOGICAL   !, INTENT(IN)                                              TRPSSR3A.80     
     &     L_SCALE_SOLAR                                                   TRPSSR3A.81     
!             SCALING APPLIED TO SOLAR FLUX                                TRPSSR3A.82     
      REAL      !, INTENT(IN)                                              TRPSSR3A.83     
     &     ADJUST_SOLAR_KE(NPD_PROFILE, NPD_LAYER)                         TRPSSR3A.84     
!             ADJUSTMENT TO SOLAR FLUXES WITH EQUIVALENT EXTINCTION        TRPSSR3A.85     
!                                                                          TRPSSR3A.86     
      REAL      !, INTENT(IN)                                              TRPSSR3A.87     
     &     FLUX_INC_DIRECT(NPD_PROFILE)                                    TRPSSR3A.88     
!             INCIDENT DIRECT SOLAR FLUX                                   TRPSSR3A.89     
!                                                                          TRPSSR3A.90     
!     OPTICAL PROPERTIES:                                                  TRPSSR3A.91     
      REAL      !, INTENT(IN)                                              TRPSSR3A.92     
     &     TRANS_0(NPD_PROFILE, NPD_LAYER, NPD_REGION)                     TRPSSR3A.93     
!             DIRECT TRANSMISSION                                          TRPSSR3A.94     
     &   , SOURCE_COEFF(NPD_PROFILE, NPD_LAYER                             TRPSSR3A.95     
     &      , NPD_SOURCE_COEFF, NPD_REGION)                                TRPSSR3A.96     
!             SOURCE COEFFICIENTS                                          TRPSSR3A.97     
!                                                                          TRPSSR3A.98     
!     ENERGY TRANSFER COEFFICIENTS:                                        TRPSSR3A.99     
      REAL      !, INTENT(IN)                                              TRPSSR3A.100    
     &     V11(NPD_PROFILE, 0: NPD_LAYER)                                  TRPSSR3A.101    
!             ENERGY TRANSFER COEFFICIENT                                  TRPSSR3A.102    
     &   , V12(NPD_PROFILE, 0: NPD_LAYER)                                  TRPSSR3A.103    
!             ENERGY TRANSFER COEFFICIENT                                  TRPSSR3A.104    
     &   , V13(NPD_PROFILE, 0: NPD_LAYER)                                  TRPSSR3A.105    
!             ENERGY TRANSFER COEFFICIENT                                  TRPSSR3A.106    
     &   , V21(NPD_PROFILE, 0: NPD_LAYER)                                  TRPSSR3A.107    
!             ENERGY TRANSFER COEFFICIENT                                  TRPSSR3A.108    
     &   , V22(NPD_PROFILE, 0: NPD_LAYER)                                  TRPSSR3A.109    
!             ENERGY TRANSFER COEFFICIENT                                  TRPSSR3A.110    
     &   , V23(NPD_PROFILE, 0: NPD_LAYER)                                  TRPSSR3A.111    
!             ENERGY TRANSFER COEFFICIENT                                  TRPSSR3A.112    
     &   , V31(NPD_PROFILE, 0: NPD_LAYER)                                  TRPSSR3A.113    
!             ENERGY TRANSFER COEFFICIENT                                  TRPSSR3A.114    
     &   , V32(NPD_PROFILE, 0: NPD_LAYER)                                  TRPSSR3A.115    
!             ENERGY TRANSFER COEFFICIENT                                  TRPSSR3A.116    
     &   , V33(NPD_PROFILE, 0: NPD_LAYER)                                  TRPSSR3A.117    
!             ENERGY TRANSFER COEFFICIENT                                  TRPSSR3A.118    
!                                                                          TRPSSR3A.119    
!     CALCULATED DIRECT FLUX AND SOURCE TERMS:                             TRPSSR3A.120    
      REAL      !, INTENT(OUT)                                             TRPSSR3A.121    
     &     FLUX_DIRECT(NPD_PROFILE, 0: NPD_LAYER)                          TRPSSR3A.122    
!             OVERALL DIRECT FLUX                                          TRPSSR3A.123    
     &   , FLUX_DIRECT_GROUND(NPD_PROFILE, NPD_REGION)                     TRPSSR3A.124    
!             DIRECT FLUXES AT GROUND BENEATH EACH REGION                  TRPSSR3A.125    
     &   , S_UP(NPD_PROFILE, NPD_LAYER, NPD_REGION)                        TRPSSR3A.126    
!             UPWARD SOURCE FUNCTIONS                                      TRPSSR3A.127    
     &   , S_DOWN(NPD_PROFILE, NPD_LAYER, NPD_REGION)                      TRPSSR3A.128    
!             DOWNWARD SOURCE FUNCTIONS                                    TRPSSR3A.129    
!                                                                          TRPSSR3A.130    
!                                                                          TRPSSR3A.131    
!     LOCAL VARIABLES.                                                     TRPSSR3A.132    
      INTEGER                                                              TRPSSR3A.133    
     &     N_REGION                                                        TRPSSR3A.134    
!             NUMBER OF REGIONS                                            TRPSSR3A.135    
      INTEGER                                                              TRPSSR3A.136    
     &     I                                                               TRPSSR3A.137    
!             LOOP VARIABLE                                                TRPSSR3A.138    
     &   , L                                                               TRPSSR3A.139    
!             LOOP VARIABLE                                                TRPSSR3A.140    
     &   , K                                                               TRPSSR3A.141    
!             LOOP VARIABLE                                                TRPSSR3A.142    
!                                                                          TRPSSR3A.143    
      REAL                                                                 TRPSSR3A.144    
     &     SOLAR_TOP(NPD_PROFILE, NPD_REGION)                              TRPSSR3A.145    
!             SOLAR FLUXES AT TOP OF LAYER                                 TRPSSR3A.146    
     &   , SOLAR_BASE(NPD_PROFILE, NPD_REGION)                             TRPSSR3A.147    
!             SOLAR FLUXES AT BASE OF LAYER                                TRPSSR3A.148    
!                                                                          TRPSSR3A.149    
!                                                                          TRPSSR3A.150    
!     SET THE NUMBER OF REGIONS.                                           TRPSSR3A.151    
      N_REGION=3                                                           TRPSSR3A.152    
!                                                                          TRPSSR3A.153    
!     THE CLEAR AND CLOUDY DIRECT FLUXES ARE CALCULATED SEPARATELY         TRPSSR3A.154    
!     AND ADDED TOGETHER TO FORM THE TOTAL DIRECT FLUX.                    TRPSSR3A.155    
!                                                                          TRPSSR3A.156    
!     SET INCIDENT FLUXES.                                                 TRPSSR3A.157    
      DO L=1, N_PROFILE                                                    TRPSSR3A.158    
         FLUX_DIRECT(L, 0)=FLUX_INC_DIRECT(L)                              TRPSSR3A.159    
      ENDDO                                                                TRPSSR3A.160    
!                                                                          TRPSSR3A.161    
!     WITH EQUIVALENT EXTINCTION THE DIRECT SOLAR FLUX MUST BE             TRPSSR3A.162    
!     CORRECTED.                                                           TRPSSR3A.163    
!                                                                          TRPSSR3A.164    
      IF (L_SCALE_SOLAR) THEN                                              TRPSSR3A.165    
!                                                                          TRPSSR3A.166    
         DO I=1, N_CLOUD_TOP-1                                             TRPSSR3A.167    
            DO L=1, N_PROFILE                                              TRPSSR3A.168    
               FLUX_DIRECT(L, I)                                           TRPSSR3A.169    
     &            =FLUX_DIRECT(L, I-1)*TRANS_0(L, I, IP_REGION_CLEAR)      TRPSSR3A.170    
     &            *ADJUST_SOLAR_KE(L, I)                                   TRPSSR3A.171    
               S_UP(L, I, IP_REGION_CLEAR)                                 TRPSSR3A.172    
     &            =SOURCE_COEFF(L, I, IP_SCF_SOLAR_UP, IP_REGION_CLEAR)    TRPSSR3A.173    
     &            *FLUX_DIRECT(L, I-1)                                     TRPSSR3A.174    
               S_DOWN(L, I, IP_REGION_CLEAR)                               TRPSSR3A.175    
     &            =(SOURCE_COEFF(L, I                                      TRPSSR3A.176    
     &            , IP_SCF_SOLAR_DOWN, IP_REGION_CLEAR)                    TRPSSR3A.177    
     &            -TRANS_0(L, I, IP_REGION_CLEAR))*FLUX_DIRECT(L, I-1)     TRPSSR3A.178    
     &            +FLUX_DIRECT(L, I)                                       TRPSSR3A.179    
            ENDDO                                                          TRPSSR3A.180    
         ENDDO                                                             TRPSSR3A.181    
!                                                                          TRPSSR3A.182    
      ELSE                                                                 TRPSSR3A.183    
!                                                                          TRPSSR3A.184    
         DO I=1, N_CLOUD_TOP-1                                             TRPSSR3A.185    
            DO L=1, N_PROFILE                                              TRPSSR3A.186    
               FLUX_DIRECT(L, I)                                           TRPSSR3A.187    
     &            =FLUX_DIRECT(L, I-1)*TRANS_0(L, I, IP_REGION_CLEAR)      TRPSSR3A.188    
               S_UP(L, I, IP_REGION_CLEAR)                                 TRPSSR3A.189    
     &            =SOURCE_COEFF(L, I, IP_SCF_SOLAR_UP, IP_REGION_CLEAR)    TRPSSR3A.190    
     &            *FLUX_DIRECT(L, I-1)                                     TRPSSR3A.191    
               S_DOWN(L, I, IP_REGION_CLEAR)                               TRPSSR3A.192    
     &            =SOURCE_COEFF(L, I                                       TRPSSR3A.193    
     &            , IP_SCF_SOLAR_DOWN, IP_REGION_CLEAR)                    TRPSSR3A.194    
     &            *FLUX_DIRECT(L, I-1)                                     TRPSSR3A.195    
            ENDDO                                                          TRPSSR3A.196    
         ENDDO                                                             TRPSSR3A.197    
!                                                                          TRPSSR3A.198    
      ENDIF                                                                TRPSSR3A.199    
!                                                                          TRPSSR3A.200    
!                                                                          TRPSSR3A.201    
!                                                                          TRPSSR3A.202    
!     CLEAR AND CLOUDY REGION.                                             TRPSSR3A.203    
!     INITIALIZE PARTIAL FLUXES:                                           TRPSSR3A.204    
      DO L=1, N_PROFILE                                                    TRPSSR3A.205    
         SOLAR_BASE(L, IP_REGION_CLEAR)=FLUX_DIRECT(L, N_CLOUD_TOP-1)      TRPSSR3A.206    
         SOLAR_BASE(L, IP_REGION_STRAT)=0.0E+00                            TRPSSR3A.207    
         SOLAR_BASE(L, IP_REGION_CONV)=0.0E+00                             TRPSSR3A.208    
      ENDDO                                                                TRPSSR3A.209    
!                                                                          TRPSSR3A.210    
!                                                                          TRPSSR3A.211    
      DO I=N_CLOUD_TOP, N_LAYER                                            TRPSSR3A.212    
!                                                                          TRPSSR3A.213    
!        TRANSFER FLUXES ACROSS THE INTERFACE.                             TRPSSR3A.214    
!                                                                          TRPSSR3A.215    
         DO L=1, N_PROFILE                                                 TRPSSR3A.216    
            SOLAR_TOP(L, IP_REGION_CLEAR)                                  TRPSSR3A.217    
     &         =V11(L, I-1)*SOLAR_BASE(L, IP_REGION_CLEAR)                 TRPSSR3A.218    
     &         +V12(L, I-1)*SOLAR_BASE(L, IP_REGION_STRAT)                 TRPSSR3A.219    
     &         +V13(L, I-1)*SOLAR_BASE(L, IP_REGION_CONV)                  TRPSSR3A.220    
            SOLAR_TOP(L, IP_REGION_STRAT)                                  TRPSSR3A.221    
     &         =V21(L, I-1)*SOLAR_BASE(L, IP_REGION_CLEAR)                 TRPSSR3A.222    
     &         +V22(L, I-1)*SOLAR_BASE(L, IP_REGION_STRAT)                 TRPSSR3A.223    
     &         +V23(L, I-1)*SOLAR_BASE(L, IP_REGION_CONV)                  TRPSSR3A.224    
            SOLAR_TOP(L, IP_REGION_CONV)                                   TRPSSR3A.225    
     &         =V31(L, I-1)*SOLAR_BASE(L, IP_REGION_CLEAR)                 TRPSSR3A.226    
     &         +V32(L, I-1)*SOLAR_BASE(L, IP_REGION_STRAT)                 TRPSSR3A.227    
     &         +V33(L, I-1)*SOLAR_BASE(L, IP_REGION_CONV)                  TRPSSR3A.228    
         ENDDO                                                             TRPSSR3A.229    
!                                                                          TRPSSR3A.230    
!                                                                          TRPSSR3A.231    
!        PROPAGATE THE FLUXES THROUGH THE LAYER:                           TRPSSR3A.232    
!                                                                          TRPSSR3A.233    
         IF (L_SCALE_SOLAR) THEN                                           TRPSSR3A.234    
!                                                                          TRPSSR3A.235    
            DO K=1, N_REGION                                               TRPSSR3A.236    
               DO L=1, N_PROFILE                                           TRPSSR3A.237    
                  SOLAR_BASE(L, K)                                         TRPSSR3A.238    
     &               =SOLAR_TOP(L, K)                                      TRPSSR3A.239    
     &               *TRANS_0(L, I, K)*ADJUST_SOLAR_KE(L, I)               TRPSSR3A.240    
                  S_UP(L, I, K)                                            TRPSSR3A.241    
     &               =SOURCE_COEFF(L, I, IP_SCF_SOLAR_UP, K)               TRPSSR3A.242    
     &               *SOLAR_TOP(L, K)                                      TRPSSR3A.243    
                  S_DOWN(L, I, K)                                          TRPSSR3A.244    
     &               =(SOURCE_COEFF(L, I, IP_SCF_SOLAR_DOWN, K)            TRPSSR3A.245    
     &               -TRANS_0(L, I, K))*SOLAR_TOP(L, K)                    TRPSSR3A.246    
     &               +SOLAR_BASE(L, K)                                     TRPSSR3A.247    
               ENDDO                                                       TRPSSR3A.248    
            ENDDO                                                          TRPSSR3A.249    
!                                                                          TRPSSR3A.250    
         ELSE                                                              TRPSSR3A.251    
!                                                                          TRPSSR3A.252    
            DO K=1, N_REGION                                               TRPSSR3A.253    
               DO L=1, N_PROFILE                                           TRPSSR3A.254    
                  SOLAR_BASE(L, K)=SOLAR_TOP(L, K)                         TRPSSR3A.255    
     &               *TRANS_0(L, I, K)                                     TRPSSR3A.256    
                  S_UP(L, I, K)                                            TRPSSR3A.257    
     &               =SOURCE_COEFF(L, I, IP_SCF_SOLAR_UP, K)               TRPSSR3A.258    
     &               *SOLAR_TOP(L, K)                                      TRPSSR3A.259    
                  S_DOWN(L, I, K)                                          TRPSSR3A.260    
     &               =SOURCE_COEFF(L, I, IP_SCF_SOLAR_DOWN, K)             TRPSSR3A.261    
     &               *SOLAR_TOP(L, K)                                      TRPSSR3A.262    
               ENDDO                                                       TRPSSR3A.263    
            ENDDO                                                          TRPSSR3A.264    
!                                                                          TRPSSR3A.265    
         ENDIF                                                             TRPSSR3A.266    
!                                                                          TRPSSR3A.267    
!                                                                          TRPSSR3A.268    
!        CALCULATE THE TOTAL DIRECT FLUX.                                  TRPSSR3A.269    
!                                                                          TRPSSR3A.270    
         DO L=1, N_PROFILE                                                 TRPSSR3A.271    
            FLUX_DIRECT(L, I)=SOLAR_BASE(L, IP_REGION_CLEAR)               TRPSSR3A.272    
     &         +SOLAR_BASE(L, IP_REGION_STRAT)                             TRPSSR3A.273    
     &         +SOLAR_BASE(L, IP_REGION_CONV)                              TRPSSR3A.274    
         ENDDO                                                             TRPSSR3A.275    
!                                                                          TRPSSR3A.276    
      ENDDO                                                                TRPSSR3A.277    
!                                                                          TRPSSR3A.278    
!     PASS THE LAST VALUE AT THE BASE OF THE CLOUD OUT.                    TRPSSR3A.279    
      DO K=1, N_REGION                                                     TRPSSR3A.280    
         DO L=1, N_PROFILE                                                 TRPSSR3A.281    
            FLUX_DIRECT_GROUND(L, K)=SOLAR_BASE(L, K)                      TRPSSR3A.282    
         ENDDO                                                             TRPSSR3A.283    
      ENDDO                                                                TRPSSR3A.284    
!                                                                          TRPSSR3A.285    
!                                                                          TRPSSR3A.286    
!                                                                          TRPSSR3A.287    
      RETURN                                                               TRPSSR3A.288    
      END                                                                  TRPSSR3A.289    
*ENDIF DEF,A01_3A,OR,DEF,A02_3A                                            TRPSSR3A.290    
*ENDIF DEF,A70_1A,OR,DEF,A70_1B                                            APB4F405.128