C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.            RAD_ALL.18994 
C                                                                                  RAD_ALL.18995 
C Use, duplication or disclosure of this code is subject to the                    RAD_ALL.18996 
C restrictions as set forth in the contract.                                       RAD_ALL.18997 
C                                                                                  RAD_ALL.18998 
C                Meteorological Office                                             RAD_ALL.18999 
C                London Road                                                       RAD_ALL.19000 
C                BRACKNELL                                                         RAD_ALL.19001 
C                Berkshire UK                                                      RAD_ALL.19002 
C                RG12 2SZ                                                          RAD_ALL.19003 
C                                                                                  RAD_ALL.19004 
C If no contract has been raised with this copy of the code, the use,              RAD_ALL.19005 
C duplication or disclosure of it is strictly prohibited.  Permission              RAD_ALL.19006 
C to do so must first be obtained in writing from the Head of Numerical            RAD_ALL.19007 
C Modelling at the above address.                                                  RAD_ALL.19008 
C ******************************COPYRIGHT******************************            RAD_ALL.19009 
C                                                                                  RAD_ALL.19010 
!+ Subroutine to calculate fluxes in a homogeneous column directly.                RAD_ALL.19011 
!                                                                                  RAD_ALL.19012 
! Method:                                                                          RAD_ALL.19013 
!       Straightforward.                                                           RAD_ALL.19014 
!                                                                                  RAD_ALL.19015 
! Current Owner of Code: J. M. Edwards                                             RAD_ALL.19016 
!                                                                                  RAD_ALL.19017 
! History:                                                                         RAD_ALL.19018 
!       Version         Date                    Comment                            RAD_ALL.19019 
!       4.1             09-04-96                Original Code                      RAD_ALL.19020 
!                                               (J. M. Edwards)                    RAD_ALL.19021 
!                                                                                  RAD_ALL.19022 
! Description of Code:                                                             RAD_ALL.19023 
!   FORTRAN 77  with extensions listed in documentation.                           RAD_ALL.19024 
!                                                                                  RAD_ALL.19025 
!- ---------------------------------------------------------------------           RAD_ALL.19026 
      SUBROUTINE SOLVER_HOMOGEN_DIRECT(N_PROFILE, N_LAYER                          RAD_ALL.19027 
     &   , TRANS, REFLECT                                                          RAD_ALL.19028 
     &   , S_DOWN, S_UP                                                            RAD_ALL.19029 
     &   , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR                                 RAD_ALL.19030 
     &   , FLUX_DIRECT_GROUND, FLUX_INC_DOWN                                       RAD_ALL.19031 
     &   , SOURCE_GROUND                                                           RAD_ALL.19032 
     &   , FLUX_TOTAL                                                              RAD_ALL.19033 
     &   , NPD_PROFILE, NPD_LAYER                                                  RAD_ALL.19034 
     &   )                                                                         RAD_ALL.19035 
!                                                                                  RAD_ALL.19036 
!                                                                                  RAD_ALL.19037 
      IMPLICIT NONE                                                                RAD_ALL.19038 
!                                                                                  RAD_ALL.19039 
!                                                                                  RAD_ALL.19040 
!     SIZES OF DUMMY ARRAYS.                                                       RAD_ALL.19041 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.19042 
     &     NPD_PROFILE                                                             RAD_ALL.19043 
!             MAXIMUM NUMBER OF PROFILES                                           RAD_ALL.19044 
     &   , NPD_LAYER                                                               RAD_ALL.19045 
!             MAXIMUM NUMBER OF LAYERS                                             RAD_ALL.19046 
!                                                                                  RAD_ALL.19047 
!                                                                                  RAD_ALL.19048 
!     DUMMY ARGUMENTS.                                                             RAD_ALL.19049 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.19050 
     &     N_PROFILE                                                               RAD_ALL.19051 
!             NUMBER OF PROFILES                                                   RAD_ALL.19052 
     &   , N_LAYER                                                                 RAD_ALL.19053 
!             NUMBER OF LAYERS                                                     RAD_ALL.19054 
      REAL      !, INTENT(IN)                                                      RAD_ALL.19055 
     &     TRANS(NPD_PROFILE, NPD_LAYER)                                           RAD_ALL.19056 
!             TRANSMISSION COEFFICIENT                                             RAD_ALL.19057 
     &   , REFLECT(NPD_PROFILE, NPD_LAYER)                                         RAD_ALL.19058 
!             REFLECTION COEFFICIENT                                               RAD_ALL.19059 
     &   , S_DOWN(NPD_PROFILE, NPD_LAYER)                                          RAD_ALL.19060 
!             DOWNWARD DIFFUSE SOURCE                                              RAD_ALL.19061 
     &   , S_UP(NPD_PROFILE, NPD_LAYER)                                            RAD_ALL.19062 
!             UPWARD DIFFUSE SOURCE                                                RAD_ALL.19063 
     &   , ALBEDO_SURFACE_DIFF(NPD_PROFILE)                                        RAD_ALL.19064 
!             DIFFUSE SURFACE ALBEDO                                               RAD_ALL.19065 
     &   , ALBEDO_SURFACE_DIR(NPD_PROFILE)                                         RAD_ALL.19066 
!             DIRECT SURFACE ALBEDO                                                RAD_ALL.19067 
     &   , SOURCE_GROUND(NPD_PROFILE)                                              RAD_ALL.19068 
!             SOURCE FUNCTION OF GROUND                                            RAD_ALL.19069 
     &   , FLUX_INC_DOWN(NPD_PROFILE)                                              RAD_ALL.19070 
!             INCIDENT TOTAL FLUX                                                  RAD_ALL.19071 
     &   , FLUX_DIRECT_GROUND(NPD_PROFILE)                                         RAD_ALL.19072 
!             DIRECT FLUX AT                                                       RAD_ALL.19073 
!                     GROUND LEVEL                                                 RAD_ALL.19074 
!                                                                                  RAD_ALL.19075 
      REAL      !, INTENT(OUT)                                                     RAD_ALL.19076 
     &     FLUX_TOTAL(NPD_PROFILE, 2*NPD_LAYER+2)                                  RAD_ALL.19077 
!             TOTAL FLUX                                                           RAD_ALL.19078 
!                                                                                  RAD_ALL.19079 
!     DECLARATION OF LOCAL VARIABLES.                                              RAD_ALL.19080 
      INTEGER                                                                      RAD_ALL.19081 
     &     I                                                                       RAD_ALL.19082 
!             LOOP VARIABLE                                                        RAD_ALL.19083 
     &   , L                                                                       RAD_ALL.19084 
!             LOOP VARIABLE                                                        RAD_ALL.19085 
!                                                                                  RAD_ALL.19086 
      REAL                                                                         RAD_ALL.19087 
     &     ALPHA(NPD_PROFILE, NPD_LAYER+1)                                         RAD_ALL.19088 
!             COMBINED ALBEDO OF LOWER LAYERS                                      RAD_ALL.19089 
     &   , BETA(NPD_PROFILE, NPD_LAYER)                                            RAD_ALL.19090 
!             WORKING ARRAY                                                        RAD_ALL.19091 
     &   , GAMMA(NPD_PROFILE, NPD_LAYER)                                           RAD_ALL.19092 
!             WORKING ARRAY                                                        RAD_ALL.19093 
     &   , H(NPD_PROFILE, NPD_LAYER)                                               RAD_ALL.19094 
!             WORKING ARRAY                                                        RAD_ALL.19095 
     &   , S_UP_PRIME(NPD_PROFILE, NPD_LAYER+1)                                    RAD_ALL.19096 
!             MODIFIED UPWARD SOURCE FUNCTION                                      RAD_ALL.19097 
!                                                                                  RAD_ALL.19098 
!                                                                                  RAD_ALL.19099 
!                                                                                  RAD_ALL.19100 
!     INITIALIZATION AT THE BOTTOM FOR UPWARD ELIMINATION:                         RAD_ALL.19101 
      DO L=1, N_PROFILE                                                            RAD_ALL.19102 
         ALPHA(L, N_LAYER+1)=ALBEDO_SURFACE_DIFF(L)                                RAD_ALL.19103 
         S_UP_PRIME(L, N_LAYER+1)=SOURCE_GROUND(L)                                 RAD_ALL.19104 
     &      +(ALBEDO_SURFACE_DIR(L)-ALBEDO_SURFACE_DIFF(L))                        RAD_ALL.19105 
     &      *FLUX_DIRECT_GROUND(L)                                                 RAD_ALL.19106 
      ENDDO                                                                        RAD_ALL.19107 
!                                                                                  RAD_ALL.19108 
!     ELIMINATING LOOP:                                                            RAD_ALL.19109 
      DO I=N_LAYER, 1, -1                                                          RAD_ALL.19110 
         DO L=1, N_PROFILE                                                         RAD_ALL.19111 
            BETA(L, I)=1.0E+00/(1.0E+00-ALPHA(L, I+1)*REFLECT(L, I))               RAD_ALL.19112 
            GAMMA(L, I)=ALPHA(L, I+1)*TRANS(L, I)                                  RAD_ALL.19113 
            H(L, I)=S_UP_PRIME(L, I+1)+ALPHA(L, I+1)*S_DOWN(L, I)                  RAD_ALL.19114 
            ALPHA(L, I)=REFLECT(L, I)                                              RAD_ALL.19115 
     &         +BETA(L, I)*GAMMA(L, I)*TRANS(L, I)                                 RAD_ALL.19116 
            S_UP_PRIME(L, I)=S_UP(L, I)+BETA(L, I)*TRANS(L, I)*H(L, I)             RAD_ALL.19117 
         ENDDO                                                                     RAD_ALL.19118 
      ENDDO                                                                        RAD_ALL.19119 
!                                                                                  RAD_ALL.19120 
!     INITIALIZE FOR BACKWARD SUBSTITUTION.                                        RAD_ALL.19121 
      DO L=1, N_PROFILE                                                            RAD_ALL.19122 
         FLUX_TOTAL(L, 2)=FLUX_INC_DOWN(L)                                         RAD_ALL.19123 
         FLUX_TOTAL(L, 1)=ALPHA(L, 1)*FLUX_TOTAL(L, 2)+S_UP_PRIME(L, 1)            RAD_ALL.19124 
      ENDDO                                                                        RAD_ALL.19125 
!                                                                                  RAD_ALL.19126 
!     BACKWARD SUBSTITUTION:                                                       RAD_ALL.19127 
      DO I=1, N_LAYER                                                              RAD_ALL.19128 
         DO L=1, N_PROFILE                                                         RAD_ALL.19129 
!           UPWARD FLUX                                                            RAD_ALL.19130 
            FLUX_TOTAL(L, 2*I+1)                                                   RAD_ALL.19131 
     &         =BETA(L, I)*(H(L, I)+GAMMA(L, I)*FLUX_TOTAL(L, 2*I))                RAD_ALL.19132 
!           DOWNWARD FLUX                                                          RAD_ALL.19133 
            FLUX_TOTAL(L, 2*I+2)=S_DOWN(L, I)                                      RAD_ALL.19134 
     &         +TRANS(L, I)*FLUX_TOTAL(L, 2*I)                                     RAD_ALL.19135 
     &         +REFLECT(L, I)*FLUX_TOTAL(L, 2*I+1)                                 RAD_ALL.19136 
         ENDDO                                                                     RAD_ALL.19137 
      ENDDO                                                                        RAD_ALL.19138 
!                                                                                  RAD_ALL.19139 
!                                                                                  RAD_ALL.19140 
!                                                                                  RAD_ALL.19141 
      RETURN                                                                       RAD_ALL.19142 
      END   
