*IF DEF,A70_1A,OR,DEF,A70_1B                                               APB4F405.103    
*IF DEF,A01_3A,OR,DEF,A02_3A                                               SOLSR3A.2      
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.    GTS2F400.13977  
C                                                                          GTS2F400.13978  
C Use, duplication or disclosure of this code is subject to the            GTS2F400.13979  
C restrictions as set forth in the contract.                               GTS2F400.13980  
C                                                                          GTS2F400.13981  
C                Meteorological Office                                     GTS2F400.13982  
C                London Road                                               GTS2F400.13983  
C                BRACKNELL                                                 GTS2F400.13984  
C                Berkshire UK                                              GTS2F400.13985  
C                RG12 2SZ                                                  GTS2F400.13986  
C                                                                          GTS2F400.13987  
C If no contract has been raised with this copy of the code, the use,      GTS2F400.13988  
C duplication or disclosure of it is strictly prohibited.  Permission      GTS2F400.13989  
C to do so must first be obtained in writing from the Head of Numerical    GTS2F400.13990  
C Modelling at the above address.                                          GTS2F400.13991  
C ******************************COPYRIGHT******************************    GTS2F400.13992  
C                                                                          GTS2F400.13993  
!+ Subroutine to calculate the solar flux and source terms.                SOLSR3A.3      
!                                                                          SOLSR3A.4      
! Method:                                                                  SOLSR3A.5      
!       Straightforward.                                                   SOLSR3A.6      
!                                                                          SOLSR3A.7      
! Current Owner of Code: J. M. Edwards                                     SOLSR3A.8      
!                                                                          SOLSR3A.9      
! History:                                                                 SOLSR3A.10     
!       Version         Date                    Comment                    SOLSR3A.11     
!       4.0             27-07-95                Original Code              SOLSR3A.12     
!                                               (J. M. Edwards)            SOLSR3A.13     
!       4.1             08-05-97                Formulation for            ADB1F401.937    
!                                               equivalent extinction      ADB1F401.938    
!                                               amended.                   ADB1F401.939    
!                                                                          SOLSR3A.14     
! Description of Code:                                                     SOLSR3A.15     
!   FORTRAN 77  with extensions listed in documentation.                   SOLSR3A.16     
!                                                                          SOLSR3A.17     
!- ---------------------------------------------------------------------   SOLSR3A.18     

      SUBROUTINE SOLAR_SOURCE(N_PROFILE, N_LAYER                            3SOLSR3A.19     
     &   , FLUX_INC_DIRECT                                                 SOLSR3A.20     
     &   , TRANS_0, SOURCE_COEFF                                           SOLSR3A.21     
     &   , L_SCALE_SOLAR, ADJUST_SOLAR_KE                                  SOLSR3A.22     
     &   , FLUX_DIRECT                                                     SOLSR3A.23     
     &   , S_DOWN, S_UP                                                    SOLSR3A.24     
     &   , NPD_PROFILE, NPD_LAYER                                          SOLSR3A.25     
     &   )                                                                 SOLSR3A.26     
!                                                                          SOLSR3A.27     
!                                                                          SOLSR3A.28     
      IMPLICIT NONE                                                        SOLSR3A.29     
!                                                                          SOLSR3A.30     
!                                                                          SOLSR3A.31     
!     SIZES OF DUMMY ARRAYS.                                               SOLSR3A.32     
      INTEGER   !, INTENT(IN)                                              SOLSR3A.33     
     &     NPD_PROFILE                                                     SOLSR3A.34     
!             MAXIMUM NUMBER OF PROFILES                                   SOLSR3A.35     
     &   , NPD_LAYER                                                       SOLSR3A.36     
!             MAXIMUM NUMBER OF LAYERS                                     SOLSR3A.37     
!                                                                          SOLSR3A.38     
!     COMDECKS INCLUDED.                                                   SOLSR3A.39     
*CALL DIMFIX3A                                                             SOLSR3A.40     
*CALL SCFPT3A                                                              SOLSR3A.41     
!                                                                          SOLSR3A.42     
!     DUMMY VARIABLES.                                                     SOLSR3A.43     
      INTEGER   !, INTENT(IN)                                              SOLSR3A.44     
     &     N_PROFILE                                                       SOLSR3A.45     
!             NUMBER OF PROFILES                                           SOLSR3A.46     
     &   , N_LAYER                                                         SOLSR3A.47     
!             NUMBER OF LAYERS                                             SOLSR3A.48     
!                                                                          SOLSR3A.49     
      LOGICAL   !, INTENT(IN)                                              SOLSR3A.50     
     &     L_SCALE_SOLAR                                                   SOLSR3A.51     
!             SCALING APPLIED TO SOLAR BEAM                                SOLSR3A.52     
!                                                                          SOLSR3A.53     
      REAL      !, INTENT(IN)                                              SOLSR3A.54     
     &     FLUX_INC_DIRECT(NPD_PROFILE)                                    SOLSR3A.55     
!             INCIDENT SOLAR FLUX                                          SOLSR3A.56     
     &   , TRANS_0(NPD_PROFILE, NPD_LAYER)                                 SOLSR3A.57     
!             DIRECT TRANSMISSION COEFFICIENT                              SOLSR3A.58     
     &   , SOURCE_COEFF(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF)          SOLSR3A.59     
!             REFLECTION COEFFICIENT                                       SOLSR3A.60     
     &   , ADJUST_SOLAR_KE(NPD_PROFILE, NPD_LAYER)                         SOLSR3A.61     
!             ADJUSTMENT TO SOLAR FLUX                                     SOLSR3A.62     
!                                                                          SOLSR3A.63     
!                                                                          SOLSR3A.64     
      REAL      !, INTENT(OUT)                                             SOLSR3A.65     
     &     FLUX_DIRECT(NPD_PROFILE, 0: NPD_LAYER)                          SOLSR3A.66     
!             DIRECT FLUX                                                  SOLSR3A.67     
     &   , S_DOWN(NPD_PROFILE, NPD_LAYER)                                  SOLSR3A.68     
!             DOWNWARD SOURCE FUNCTION                                     SOLSR3A.69     
     &   , S_UP(NPD_PROFILE, NPD_LAYER)                                    SOLSR3A.70     
!             UPWARD SOURCE FUNCTION                                       SOLSR3A.71     
!                                                                          SOLSR3A.72     
!                                                                          SOLSR3A.73     
!     LOCAL VARIABLES.                                                     SOLSR3A.74     
      INTEGER                                                              SOLSR3A.75     
     &     I                                                               SOLSR3A.76     
!             LOOP VARIABLE                                                SOLSR3A.77     
     &   , L                                                               SOLSR3A.78     
!             LOOP VARIABLE                                                SOLSR3A.79     
!                                                                          SOLSR3A.80     
!                                                                          SOLSR3A.81     
!                                                                          SOLSR3A.82     
      DO L=1, N_PROFILE                                                    SOLSR3A.83     
         FLUX_DIRECT(L, 0)=FLUX_INC_DIRECT(L)                              SOLSR3A.84     
      ENDDO                                                                SOLSR3A.85     
!                                                                          SOLSR3A.86     
!     THE SOLAR FLUX MAY BE MULTIPLIED BY A SCALING FACTOR IF AN           SOLSR3A.87     
!     EQUIVALENT EXTINCTION IS USED.                                       SOLSR3A.88     
!                                                                          SOLSR3A.89     
      IF (L_SCALE_SOLAR) THEN                                              SOLSR3A.90     
!                                                                          SOLSR3A.91     
         DO I=1, N_LAYER                                                   SOLSR3A.92     
            DO L=1, N_PROFILE                                              SOLSR3A.93     
               FLUX_DIRECT(L, I)                                           SOLSR3A.94     
     &            =FLUX_DIRECT(L, I-1)*TRANS_0(L, I)                       SOLSR3A.95     
     &            *ADJUST_SOLAR_KE(L, I)                                   SOLSR3A.96     
               S_UP(L, I)=SOURCE_COEFF(L, I, IP_SCF_SOLAR_UP)              SOLSR3A.97     
     &            *FLUX_DIRECT(L, I-1)                                     SOLSR3A.98     
               S_DOWN(L, I)=(SOURCE_COEFF(L, I, IP_SCF_SOLAR_DOWN)         ADB1F401.940    
     &            -TRANS_0(L, I))*FLUX_DIRECT(L, I-1)                      ADB1F401.941    
     &            +FLUX_DIRECT(L, I)                                       ADB1F401.942    
            ENDDO                                                          SOLSR3A.101    
         ENDDO                                                             SOLSR3A.102    
!                                                                          SOLSR3A.103    
      ELSE                                                                 SOLSR3A.104    
!                                                                          SOLSR3A.105    
         DO I=1, N_LAYER                                                   SOLSR3A.106    
            DO L=1, N_PROFILE                                              SOLSR3A.107    
               FLUX_DIRECT(L, I)                                           SOLSR3A.108    
     &            =FLUX_DIRECT(L, I-1)*TRANS_0(L, I)                       SOLSR3A.109    
               S_UP(L, I)=SOURCE_COEFF(L, I, IP_SCF_SOLAR_UP)              SOLSR3A.110    
     &            *FLUX_DIRECT(L, I-1)                                     SOLSR3A.111    
               S_DOWN(L, I)=SOURCE_COEFF(L, I, IP_SCF_SOLAR_DOWN)          SOLSR3A.112    
     &            *FLUX_DIRECT(L, I-1)                                     SOLSR3A.113    
            ENDDO                                                          SOLSR3A.114    
         ENDDO                                                             SOLSR3A.115    
!                                                                          SOLSR3A.116    
      ENDIF                                                                SOLSR3A.117    
!                                                                          SOLSR3A.118    
!                                                                          SOLSR3A.119    
      RETURN                                                               SOLSR3A.120    
      END                                                                  SOLSR3A.121    
*ENDIF DEF,A01_3A,OR,DEF,A02_3A                                            SOLSR3A.122    
*ENDIF DEF,A70_1A,OR,DEF,A70_1B                                            APB4F405.104