C ###############################################################
C #                                                             #
C #                    THE VLIDORT  MODEL                       #
C #                                                             #
C #  Vectorized LInearized Discrete Ordinate Radiative Transfer #
C #  -          --         -        -        -         -        #
C #                                                             #
C ###############################################################

C ###############################################################
C #                                                             #
C #  Author :      Robert. J. D. Spurr                          #
C #                                                             #
C #  Address :      RT Solutions, Inc.                          #
C #            9 Channing Street                                #
C #             Cambridge, MA 02138, USA                        #
C #            Tel: (617) 492 1183                              #
C #                                                             #
C #  Email :      rtsolutions@verizon.net                       #
C #                                                             #
C #  Versions     :   2.0, 2.2, 2.3, 2.4, 2.4R                  #
C #  Release Date :   December 2005  (2.0)                      #
C #  Release Date :   March 2007     (2.2)                      #
C #  Release Date :   October 2007   (2.3)                      #
C #  Release Date :   December 2008  (2.4)                      #
C #  Release Date :   April/May 2009 (2.4R)                     #
C #  Release Date :   July 2009      (2.4RT)                    #
C #                                                             #
C #       NEW: TOTAL COLUMN JACOBIANS         (2.4)             #
C #       NEW: BPDF Land-surface KERNELS      (2.4R)            #
C #       NEW: Thermal Emission Treatment     (2.4RT)           #
C #                                                             #
C ###############################################################

C    #####################################################
C    #                                                   #
C    #   This Version of VLIDORT comes with a GNU-style  #
C    #   license. Please read the license carefully.     #
C    #                                                   #
C    #####################################################

C ##########################################################
C #                                                        #
C # Subroutines in this Module                             #
C #                                                        #
C #     Top level routines--------------                   #
C #                                                        #
C #            VLIDORT_UPUSER_ATMOSWF                      #
C #            VLIDORT_DNUSER_ATMOSWF                      #
C #                                                        #
C #     Post-processing at user angles --------            #
C #                                                        #
C #            GET_L_TOASOURCE                             #
C #            L_BOA_LAMBERTIAN_SOURCE                     #
C #                                                        #
C #            L_WHOLELAYER_STERM_UP                       #
C #            L_WHOLELAYER_STERM_DN                       #
C #            L_PARTLAYER_STERM_UP                        #
C #            L_PARTLAYER_STERM_DN                        #
C #                                                        #
C ##########################################################

      SUBROUTINE VLIDORT_UPUSER_ATMOSWF
     I   ( DO_INCLUDE_SURFACE,
     I     DO_INCLUDE_THERMEMISS,
     I     DO_INCLUDE_MVOUTPUT,
     I     DO_INCLUDE_DIRECTBEAM,
     I     SURFACE_FACTOR,    FLUX_MULTIPLIER,
     I     FOURIER_COMPONENT, IBEAM,
     I     LAYER_TO_VARY, NV_PARAMETERS,
     I     L_GET_BOA_SOURCE )

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution and reflectance variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_REFLECTANCE.VARS'

C  include files of linearized setup and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_MULTIPLIERS.VARS'

C  include file of result variables (module output stored here)

      INCLUDE '../includes/VLIDORT_RESULTS.VARS'
      INCLUDE '../includes/VLIDORT_L_RESULTS.VARS'

C  Subroutine input arguments
C  --------------------------

C  local control flags

      LOGICAL          DO_INCLUDE_SURFACE
      LOGICAL          DO_INCLUDE_DIRECTBEAM
      LOGICAL          DO_INCLUDE_THERMEMISS
      LOGICAL          DO_INCLUDE_MVOUTPUT

C  Linearization control

      INTEGER          LAYER_TO_VARY, NV_PARAMETERS

C  External function

      EXTERNAL         L_GET_BOA_SOURCE

C  Input Fourier number and beam index
C  surface factor (2 for m = 0, 1 otherwise)
C  Flux multiplier = F/4.pi

      INTEGER          FOURIER_COMPONENT, IBEAM
      DOUBLE PRECISION SURFACE_FACTOR
      DOUBLE PRECISION FLUX_MULTIPLIER

C  local variables
C  ---------------

      LOGICAL          SFLAG
      INTEGER          N, NUT, NSTART, NUT_PREV, NLEVEL, O1
      INTEGER          UTA, UM, NV, Q, NC, UT, IB

      DOUBLE PRECISION L_CUMUL_SOURCE
     &        ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )

      DOUBLE PRECISION L_BOA_MSSOURCE
     &        ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )
      DOUBLE PRECISION L_BOA_DBSOURCE
     &        ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )

      DOUBLE PRECISION L_LAYER_SOURCE
     &        ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )

      DOUBLE PRECISION L_FINAL_SOURCE

C  index

      NV = LAYER_TO_VARY
      IB = IBEAM

C  Zero all Fourier components - New rule, better for safety
C    Only did this for components close to zenith (formerly)

      IF ( DO_USER_STREAMS ) THEN
        DO UTA = 1, N_USER_LEVELS
          DO Q = 1, NV_PARAMETERS
            DO UM = 1, N_USER_STREAMS
              DO O1 = 1, NSTOKES
                ATMOSWF_F(Q,NV,UTA,UM,IB,O1,UPIDX) = ZERO
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      ENDIF

C  Initialize post-processing recursion
C  ====================================

      IF ( DO_USER_STREAMS ) THEN

C  Get the linearized BOA source terms (diffuse and direct)

        CALL L_GET_BOA_SOURCE
     I    ( DO_INCLUDE_SURFACE,
     I      DO_INCLUDE_THERMEMISS,
     I      DO_INCLUDE_DIRECTBEAM,
     I      DO_INCLUDE_MVOUTPUT,
     I      SURFACE_FACTOR,
     I      FOURIER_COMPONENT, IBEAM,
     I      NV, NV_PARAMETERS,
     O      L_BOA_MSSOURCE,
     O      L_BOA_DBSOURCE )

C  Set the cumuluative source term equal to the BOA sum

        DO UM = LOCAL_UM_START, N_USER_STREAMS
         DO O1 = 1, NSTOKES
          DO Q = 1, NV_PARAMETERS
            L_CUMUL_SOURCE(UM,O1,Q) = L_BOA_MSSOURCE(UM,O1,Q) +
     &                                L_BOA_DBSOURCE(UM,O1,Q)
          ENDDO
         ENDDO
        ENDDO

C  Debug

        IF ( DO_DEBUG_WRITE ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
           DO O1 = 1, NSTOKES
            DO Q = 1, NV_PARAMETERS
            IF ( FOURIER_COMPONENT.EQ.0.and.q.eq.2.and.nv.eq.2)then
              if (um.eq.1.and.o1.eq.1)write(83,*)UM,O1,
     &         L_BOA_MSSOURCE(UM,O1,Q), L_BOA_DBSOURCE(UM,O1,Q)
            endif
            ENDDO
           ENDDO
          ENDDO
        ENDIF

      ENDIF

C  Recursion Loop for linearized Post-processing
C  =============================================

C  initialise cumulative source term loop

      NC  = 0
      NUT = 0
      NSTART = NLAYERS
      NUT_PREV = NSTART + 1

C  loop over all output optical depths
C  -----------------------------------

      DO UTA = N_USER_LEVELS, 1, -1

C  Layer index for given optical depth

        NLEVEL = UTAU_LEVEL_MASK_UP(UTA)

C  Cumulative source terms to layer NUT (user-defined stream angles only)
C    1. Get layer source terms
C    2. Find cumulative source term
C    3. Set multiple scatter source term (MSST) output if flagged

        IF ( DO_USER_STREAMS ) THEN
          NUT = NLEVEL + 1
          DO N = NSTART, NUT, -1
            SFLAG = DO_LAYER_SCATTERING(FOURIER_COMPONENT,N)
            NC = NLAYERS + 1 - N
            CALL L_WHOLELAYER_STERM_UP
     I       ( FOURIER_COMPONENT, IB, N, SFLAG,
     I         NV, NV_PARAMETERS, DO_INCLUDE_THERMEMISS,
     O         L_LAYER_SOURCE )
            IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
              DO UM = LOCAL_UM_START, N_USER_STREAMS
                DO O1 = 1, NSTOKES
                  DO Q = 1, NV_PARAMETERS
                    L_CUMUL_SOURCE(UM,O1,Q) = L_LAYER_SOURCE(UM,O1,Q)
     &               +   T_DELT_USERM(N,UM)   * L_CUMUL_SOURCE(UM,O1,Q)
     &               + L_T_DELT_USERM(N,UM,Q) * CUMSOURCE_UP(UM,O1,NC-1)
                  ENDDO
                ENDDO
              ENDDO
            ELSE IF ( N.NE.NV.AND.NV.NE.0 ) THEN
              DO UM = LOCAL_UM_START, N_USER_STREAMS
                DO O1 = 1, NSTOKES
                  DO Q = 1, NV_PARAMETERS
                    L_CUMUL_SOURCE(UM,O1,Q) = L_LAYER_SOURCE(UM,O1,Q)
     &               +   T_DELT_USERM(N,UM)   * L_CUMUL_SOURCE(UM,O1,Q)
                  ENDDO
                ENDDO
              ENDDO
            ENDIF
          ENDDO
        ENDIF

C  Offgrid output
C  --------------

        IF ( PARTLAYERS_OUTFLAG(UTA) ) THEN

          UT    = PARTLAYERS_OUTINDEX(UTA)
          N     = PARTLAYERS_LAYERIDX(UT)
          SFLAG = DO_LAYER_SCATTERING(FOURIER_COMPONENT,N)

C  User-defined stream output, add additional partial layer source term

          IF ( DO_USER_STREAMS ) THEN
            CALL L_PARTLAYER_STERM_UP
     I   ( IB, UT, N, SFLAG, NV, NV_PARAMETERS, DO_INCLUDE_THERMEMISS,
     O     L_LAYER_SOURCE )
            IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
              DO UM = LOCAL_UM_START, N_USER_STREAMS
                DO O1 = 1, NSTOKES
                  DO Q = 1, NV_PARAMETERS
                    L_FINAL_SOURCE = L_LAYER_SOURCE(UM,O1,Q)
     &              +   T_UTUP_USERM(UT,UM)   * L_CUMUL_SOURCE(UM,O1,Q)
     &              + L_T_UTUP_USERM(UT,UM,Q) *   CUMSOURCE_UP(UM,O1,NC)
                    ATMOSWF_F(Q,NV,UTA,UM,IB,O1,UPIDX) =
     &                   FLUX_MULTIPLIER * L_FINAL_SOURCE
                  ENDDO
                ENDDO
              ENDDO
            ELSE IF ( N.NE.NV .AND. NV.NE.0 ) THEN
              DO UM = LOCAL_UM_START, N_USER_STREAMS
                DO O1 = 1, NSTOKES
                  DO Q = 1, NV_PARAMETERS
                    L_FINAL_SOURCE = L_LAYER_SOURCE(UM,O1,Q)
     &              +   T_UTUP_USERM(UT,UM)   * L_CUMUL_SOURCE(UM,O1,Q)
                    ATMOSWF_F(Q,NV,UTA,UM,IB,O1,UPIDX) =
     &                  FLUX_MULTIPLIER * L_FINAL_SOURCE
                  ENDDO
                ENDDO
              ENDDO
            ENDIF
          ENDIF

C  Ongrid output
C  -------------

        ELSE

C  User-defined stream output, just set to the cumulative source term

          IF ( DO_USER_STREAMS ) THEN
            DO UM = LOCAL_UM_START, N_USER_STREAMS
              DO O1 = 1, NSTOKES
                DO Q = 1, NV_PARAMETERS
                  L_FINAL_SOURCE =
     &                   FLUX_MULTIPLIER * L_CUMUL_SOURCE(UM,O1,Q)
!                  if (DABS(L_FINAL_SOURCE).GT.1.0d-12 ) then
                    ATMOSWF_F(Q,NV,UTA,UM,IB,O1,UPIDX) = L_FINAL_SOURCE
!                  endif
!      if(fourier_component.eq.3.and.q.eq.3)
!     &            write(*,*)uta,um,q,L_CUMUL_SOURCE(UM,1,Q)
                ENDDO
              ENDDO
            ENDDO
          ENDIF

        ENDIF

C  debug

c        IF ( DO_DEBUG_WRITE ) THEN
c          DO UM = LOCAL_UM_START, N_USER_STREAMS
c            DO O1 = 1, NSTOKES
c              DO Q = 1, NV_PARAMETERS
c                if(q.eq.1.and.nv.lt.10) write(70,'(5i3,1p2e20.10)')
c     &         fourier_component,uta,nv,um,o1,
c     &           STOKES_F(UTA,UM,IBEAM,O1,UPIDX),
c     &           ATMOSWF_F(Q,NV,UTA,UM,IBEAM,O1,UPIDX)
c              ENDDO
c            ENDDO
c          ENDDO
c        ENDIF
c         if (nv.eq.10)pause

C  Check for updating the recursion

        IF ( DO_USER_STREAMS ) THEN
          IF ( NUT. NE. NUT_PREV ) NSTART = NUT - 1
          NUT_PREV = NUT
        ENDIF

C  end loop over optical depth

      ENDDO

C  Finish

      RETURN
      END

C

      SUBROUTINE VLIDORT_DNUSER_ATMOSWF
     I    ( DO_INCLUDE_THERMEMISS,
     I      FLUX_MULTIPLIER,
     I      FOURIER_COMPONENT, IBEAM,
     I      LAYER_TO_VARY, NV_PARAMETERS )

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution and reflectance variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_REFLECTANCE.VARS'

C  include files of linearized setup and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_MULTIPLIERS.VARS'

C  include file of result variables (module output stored here)

      INCLUDE '../includes/VLIDORT_L_RESULTS.VARS'

C  Subroutine input arguments
C  --------------------------

C  thermal emission control

      LOGICAL          DO_INCLUDE_THERMEMISS

C  Input Fourier number and beam index
C  Flux multiplier = F/4.pi

      INTEGER          FOURIER_COMPONENT, IBEAM
      DOUBLE PRECISION FLUX_MULTIPLIER

C  Linearization control

      INTEGER          LAYER_TO_VARY, NV_PARAMETERS

C  local variables
C  ---------------

      LOGICAL          SFLAG
      INTEGER          N, NUT, NSTART, NUT_PREV, NLEVEL, O1
      INTEGER          UTA, UM, NV, Q, NC, UT, IB, M

      DOUBLE PRECISION L_CUMUL_SOURCE
     &        ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )

      DOUBLE PRECISION L_TOA_SOURCE
     &        ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )

      DOUBLE PRECISION L_LAYER_SOURCE
     &        ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )

      DOUBLE PRECISION L_FINAL_SOURCE

C  Initialise

      NV = LAYER_TO_VARY
      IB = IBEAM
      M  = FOURIER_COMPONENT

C  Zero all Fourier component output

      IF ( DO_USER_STREAMS ) THEN
        DO UTA = 1, N_USER_LEVELS
          DO Q = 1, NV_PARAMETERS
            DO UM = 1, LOCAL_UM_START
              DO O1 = 1, NSTOKES
                ATMOSWF_F(Q,NV,UTA,UM,IB,O1,DNIDX) = ZERO
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      ENDIF

C  Initialize post-processing recursion
C  ====================================

C  Get the linearized TOA source terms

      IF ( DO_USER_STREAMS ) THEN
        CALL GET_L_TOASOURCE ( L_TOA_SOURCE, NV_PARAMETERS )
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            DO Q = 1, NV_PARAMETERS
              L_CUMUL_SOURCE(UM,O1,Q) = L_TOA_SOURCE(UM,O1,Q)
            ENDDO
          ENDDO
        ENDDO
      ENDIF

C  Recursion Loop for linearized Post-processing
C  =============================================

C  initialise cumulative source term loop

      NC  = 0
      NUT = 0
      NSTART = 1
      NUT_PREV = NSTART - 1

C  loop over all output optical depths
C  -----------------------------------

      DO UTA = 1, N_USER_LEVELS

C  Layer index for given optical depth

        NLEVEL = UTAU_LEVEL_MASK_DN(UTA)

C  Cumulative source terms to layer NUT (user-defined stream angles only)
C    1. Get layer source terms
C    2. Find cumulative source term
C    3. Set multiple scatter source term output if flagged

        IF ( DO_USER_STREAMS ) THEN
          NUT = NLEVEL
          DO N = NSTART, NUT
            SFLAG = DO_LAYER_SCATTERING(FOURIER_COMPONENT,N)
            NC = N
            CALL L_WHOLELAYER_STERM_DN
     &       ( IB, N, SFLAG, NV, NV_PARAMETERS, DO_INCLUDE_THERMEMISS,
     O         L_LAYER_SOURCE )

            IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
              DO UM = LOCAL_UM_START, N_USER_STREAMS
                DO O1 = 1, NSTOKES
                  DO Q = 1, NV_PARAMETERS
                    L_CUMUL_SOURCE(UM,O1,Q) = L_LAYER_SOURCE(UM,O1,Q)
     &               +   T_DELT_USERM(N,UM)   * L_CUMUL_SOURCE(UM,O1,Q)
     &               + L_T_DELT_USERM(N,UM,Q) * CUMSOURCE_DN(UM,O1,NC-1)
                  ENDDO
                ENDDO
              ENDDO
            ELSE IF ( N.NE.NV.AND.NV.NE.0 ) THEN
              DO UM = LOCAL_UM_START, N_USER_STREAMS
                DO O1 = 1, NSTOKES
                  DO Q = 1, NV_PARAMETERS
                    L_CUMUL_SOURCE(UM,O1,Q) = L_LAYER_SOURCE(UM,O1,Q)
     &               +   T_DELT_USERM(N,UM) * L_CUMUL_SOURCE(UM,O1,Q)
                  ENDDO
                ENDDO
              ENDDO
            ENDIF
          ENDDO
        ENDIF

C  Offgrid output
C  --------------

        IF ( PARTLAYERS_OUTFLAG(UTA) ) THEN

          UT    = PARTLAYERS_OUTINDEX(UTA)
          N     = PARTLAYERS_LAYERIDX(UT)
          SFLAG = DO_LAYER_SCATTERING(FOURIER_COMPONENT,N)

C  User-defined stream output, add additional partial layer source term

          IF ( DO_USER_STREAMS ) THEN
            CALL L_PARTLAYER_STERM_DN
     I    ( IB, UT, N, SFLAG, NV, NV_PARAMETERS, DO_INCLUDE_THERMEMISS,
     O      L_LAYER_SOURCE )
            IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
              DO UM = LOCAL_UM_START, N_USER_STREAMS
                DO O1 = 1, NSTOKES
                  DO Q = 1, NV_PARAMETERS
                    L_FINAL_SOURCE = L_LAYER_SOURCE(UM,O1,Q)
     &              +   T_UTDN_USERM(UT,UM)   * L_CUMUL_SOURCE(UM,O1,Q)
     &              + L_T_UTDN_USERM(UT,UM,Q) *   CUMSOURCE_DN(UM,O1,NC)
                    ATMOSWF_F(Q,NV,UTA,UM,IB,O1,DNIDX) =
     &                FLUX_MULTIPLIER * L_FINAL_SOURCE
                  ENDDO
                ENDDO
              ENDDO
            ELSE IF ( N.NE.NV.AND.NV.NE.0 ) THEN
              DO UM = LOCAL_UM_START, N_USER_STREAMS
                DO O1 = 1, NSTOKES
                  DO Q = 1, NV_PARAMETERS
                    L_FINAL_SOURCE = L_LAYER_SOURCE(UM,O1,Q)
     &              +   T_UTDN_USERM(UT,UM)   * L_CUMUL_SOURCE(UM,O1,Q)
                    ATMOSWF_F(Q,NV,UTA,UM,IB,O1,DNIDX) =
     &                FLUX_MULTIPLIER * L_FINAL_SOURCE
                  ENDDO
                ENDDO
              ENDDO
            ENDIF
          ENDIF

C  Ongrid output
C  -------------

        ELSE

C  User-defined stream output, just set to the cumulative source term

          IF ( DO_USER_STREAMS ) THEN
            DO UM = LOCAL_UM_START, N_USER_STREAMS
              DO O1 = 1, NSTOKES
                DO Q = 1, NV_PARAMETERS
                  ATMOSWF_F(Q,NV,UTA,UM,IB,O1,DNIDX) =
     &                    FLUX_MULTIPLIER * L_CUMUL_SOURCE(UM,O1,Q)
                ENDDO
              ENDDO
            ENDDO
          ENDIF

        ENDIF

C  Check for updating the recursion

        IF ( DO_USER_STREAMS ) THEN
          IF ( NUT. NE. NUT_PREV ) NSTART = NUT + 1
          NUT_PREV = NUT
        ENDIF

C  end loop over optical depth

      ENDDO

C  Finish

      RETURN
      END

C

      SUBROUTINE GET_L_TOASOURCE ( L_TOA_SOURCE, NV_PARAMETERS )

C  Include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  Subroutine arguments
C  --------------------

      INTEGER          NV_PARAMETERS
      DOUBLE PRECISION L_TOA_SOURCE
     &           (MAX_USER_STREAMS,MAXSTOKES,MAX_ATMOSWFS)

C  local variables
C  ---------------

      INTEGER          UM, Q, O1

C  initialise TOA source function
C  ------------------------------

      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO Q = 1, NV_PARAMETERS
          DO O1 = 1, NSTOKES
            L_TOA_SOURCE(UM,O1,Q) = ZERO
          ENDDO
        ENDDO
      ENDDO

C  Finish

      RETURN
      END

C

      SUBROUTINE L_BOA_LAMBERTIAN_SOURCE
     I    ( DO_INCLUDE_SURFACE,
     I      DO_INCLUDE_THERMEMISS,
     I      DO_INCLUDE_DIRECTBEAM,
     I      DO_INCLUDE_MVOUTPUT,
     I      SURFACE_FACTOR,
     I      FOURIER_COMPONENT, IBEAM,
     I      NV, NV_PARAMETERS,
     O      L_BOA_MSSOURCE,
     O      L_BOA_DBSOURCE )

C  Linearized Bottom of the atmosphere source term

C  Include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution and reflectance variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'
      INCLUDE '../includes/VLIDORT_REFLECTANCE.VARS'

C  include files of linearized setup and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_THERMALSUP.VARS'

C  Subroutine input arguments
C  --------------------------

C  local control flags

      LOGICAL          DO_INCLUDE_SURFACE
      LOGICAL          DO_INCLUDE_DIRECTBEAM
      LOGICAL          DO_INCLUDE_MVOUTPUT

C  thermal emission control

      LOGICAL          DO_INCLUDE_THERMEMISS

C  albedo and Fourier/beam indices

      DOUBLE PRECISION SURFACE_FACTOR
      INTEGER          FOURIER_COMPONENT, IBEAM

C  linearization control

      INTEGER          NV, NV_PARAMETERS

C  output arguments
C  ----------------

      DOUBLE PRECISION L_BOA_MSSOURCE
     &          (MAX_USER_STREAMS,MAXSTOKES,MAX_ATMOSWFS)
      DOUBLE PRECISION L_BOA_DBSOURCE
     &          (MAX_USER_STREAMS,MAXSTOKES,MAX_ATMOSWFS)

C  local variables
C  ---------------

      INTEGER          M, N, NN, J, I, UM, Q, IB, O1
      INTEGER          K, KO1, K0, K1, K2

      LOGICAL          DO_QTHTONLY
      DOUBLE PRECISION DOWN   (MAXSTREAMS)
      DOUBLE PRECISION L_DOWN (MAXSTREAMS,MAX_ATMOSWFS)
      DOUBLE PRECISION REFLEC, L_BEAM, FAC, KMULT
      DOUBLE PRECISION SHOM_R, SHOM_CR, SHOM
      DOUBLE PRECISION HOM1, HOM2, HOM1CR, HOM2CR, HOM3CR
      DOUBLE PRECISION LXR, NXR, PXR, LLXR, MLXR
      DOUBLE PRECISION LXR1, NXR1, PXR1, LLXR1, MLXR1
      DOUBLE PRECISION LXR2, NXR2, LLXR2

C  Starting section
C  ----------------

C  Fourier number, layer number

      M   = FOURIER_COMPONENT
      N   = NLAYERS
      KO1 = K_REAL(N) + 1
      IB  = IBEAM

C  Special flag

      DO_QTHTONLY = ( DO_THERMAL_TRANSONLY ) .AND.
     &      ( DO_QUAD_OUTPUT .OR. DO_INCLUDE_MVOUTPUT )

C  initialise linearized BOA source functions

      IF ( DO_USER_STREAMS ) THEN
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO Q = 1, NV_PARAMETERS
            DO O1 = 1, NSTOKES
              L_BOA_MSSOURCE(UM,O1,Q) = ZERO
              L_BOA_DBSOURCE(UM,O1,Q) = ZERO
            ENDDO
          ENDDO
        ENDDO
      ENDIF

C  Thermal tranmsittance only, special term

      IF ( DO_QTHTONLY ) THEN
        DO I = 1, NSTREAMS
          DO Q = 1, NV_PARAMETERS
            L_BOA_THTONLY_SOURCE(I,Q) = ZERO
          ENDDO
        ENDDO
      ENDIF

C  reflectance from surface
C  ------------------------

C  Only want the (1,1) component

      O1 = 1

C  reflectance integrand  a(j).x(j).L(downwelling)(-j)

      IF ( DO_INCLUDE_SURFACE ) THEN

C  1. Thermal Transmittance only
C     %%%%%%%%%%%%%%%%%%%%%%%%%%

C  Thermal transmittance solution, build from TOA downwards

        IF ( DO_THERMAL_TRANSONLY ) THEN

C  Initialise

          DO I = 1, NSTREAMS
            DOWN(I) = ZERO
            DO Q = 1, NV_PARAMETERS
              L_DOWN(I,Q) = ZERO
            ENDDO
          ENDDO

C  Build

          DO NN = 1, NLAYERS
            IF ( NV.EQ.0. OR. NV.EQ.NN ) THEN
              DO I = 1, NSTREAMS
                DO Q = 1, NV_PARAMETERS
                  L_DOWN(I,Q) = L_DOWN(I,Q) *   T_DELT_DISORDS(I,NN)
     &                          + DOWN(I)   * L_T_DELT_DISORDS(I,NN,Q)
     &                          + L_T_WLOWER(I,NN,Q)
                ENDDO
              ENDDO
            ELSE
              DO I = 1, NSTREAMS
                DO Q = 1, NV_PARAMETERS
                  L_DOWN(I,Q) = L_DOWN(I,Q) * T_DELT_DISORDS(I,NN)
                ENDDO
              ENDDO
            ENDIF
            DO I = 1, NSTREAMS
              DOWN(I) = DOWN(I)*T_DELT_DISORDS(I,NN) + T_WLOWER(I,NN)
            ENDDO
          ENDDO

C  Finalize

          DO I = 1, NSTREAMS
            DO Q = 1, NV_PARAMETERS
              L_DOWN(I,Q) = QUAD_WEIGHTS(I) * L_DOWN(I,Q)
            ENDDO
          ENDDO

C  Continuation point for avoiding the next section

          GO TO 5432

        ENDIF

C  2. Scattering solutions
C     %%%%%%%%%%%%%%%%%%%%

C  Two cases:
C  (a) If  NV = N, this is also the layer that is varying --> Extras!
C  (b) If  N > NV with variations in layer NV above N

        IF ( NV .EQ. N .OR. NV.EQ.0 ) THEN

C  stream and stokes loops

          DO I = 1, NSTREAMS

C  Parameter loop

            DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

             SHOM_R = ZERO
             DO K = 1, K_REAL(N)
              LXR  = LCON(K,N)   *   SOLA_XPOS(I,O1,K,N)
              LLXR = LCON(K,N)   * L_SOLA_XPOS(I,O1,K,N,Q)
              MLXR = MCON(K,N)   * L_SOLB_XNEG(I,O1,K,N,Q)
              NXR  = NCON(K,N,Q) *   SOLA_XPOS(I,O1,K,N)
              PXR  = PCON(K,N,Q) *   SOLB_XNEG(I,O1,K,N)
              HOM1 = ( NXR + LLXR ) *   T_DELT_EIGEN(K,N)
     &                     +  LXR   * L_T_DELT_EIGEN(K,N,Q)
              HOM2 = PXR + MLXR
              SHOM_R = SHOM_R + HOM1 + HOM2
             ENDDO

C  Complex homogeneous solutions

             SHOM_CR = ZERO
             KO1 = K_REAL(N) + 1
             DO K = 1, K_COMPLEX(N)
              K0 = 2 * K - 2
              K1 = KO1 + K0
              K2 = K1  + 1
              NXR1  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K1,N)
     &                - NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K2,N)
              NXR2  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K2,N)
     &                + NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K1,N)
              PXR1  =   PCON(K1,N,Q) *   SOLB_XNEG(I,O1,K1,N)
     &                - PCON(K2,N,Q) *   SOLB_XNEG(I,O1,K2,N)
              LXR1  =   LCON(K1,N) *   SOLA_XPOS(I,O1,K1,N)
     &                - LCON(K2,N) *   SOLA_XPOS(I,O1,K2,N)
              LXR2  =   LCON(K1,N) *   SOLA_XPOS(I,O1,K2,N)
     &                + LCON(K2,N) *   SOLA_XPOS(I,O1,K1,N)
              LLXR1  =   LCON(K1,N) * L_SOLA_XPOS(I,O1,K1,N,Q)
     &                 - LCON(K2,N) * L_SOLA_XPOS(I,O1,K2,N,Q)
              LLXR2  =   LCON(K1,N) * L_SOLA_XPOS(I,O1,K2,N,Q)
     &                 + LCON(K2,N) * L_SOLA_XPOS(I,O1,K1,N,Q)
              MLXR1  =   MCON(K1,N) * L_SOLB_XNEG(I,O1,K1,N,Q)
     &                 - MCON(K2,N) * L_SOLB_XNEG(I,O1,K2,N,Q)
              HOM1CR =   ( NXR1 + LLXR1 ) *   T_DELT_EIGEN(K1,N)
     &                 - ( NXR2 + LLXR2 ) *   T_DELT_EIGEN(K2,N)
              HOM2CR =             LXR1   * L_T_DELT_EIGEN(K1,N,Q)
     &                           - LXR2   * L_T_DELT_EIGEN(K2,N,Q)
              HOM3CR = PXR1 + MLXR1
              SHOM_CR = SHOM_CR + HOM1CR + HOM2CR + HOM3CR
             ENDDO

C  real part

             SHOM = SHOM_R + SHOM_CR
             L_DOWN(I,Q) = SHOM

C  End loops over Q and I

            ENDDO
          ENDDO

C  otherwise the varying layer is above the boundary layer

        ELSE IF ( NV.LT.N .AND.NV.NE.0 ) THEN

C  stream and stokes loops

          DO I = 1, NSTREAMS

C  Parameter loop

            DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

             SHOM_R = ZERO
             DO K = 1, K_REAL(N)
              NXR = NCON(K,N,Q) *   SOLA_XPOS(I,O1,K,N)
              PXR = PCON(K,N,Q) *   SOLB_XNEG(I,O1,K,N)
              HOM1 = NXR * T_DELT_EIGEN(K,N)
              HOM2 = PXR
              SHOM_R = SHOM_R + HOM1 + HOM2
             ENDDO

C  Complex homogeneous solutions

             SHOM_CR = ZERO
             KO1 = K_REAL(N) + 1
             DO K = 1, K_COMPLEX(N)
              K0 = 2 * K - 2
              K1 = KO1 + K0
              K2 = K1  + 1
              NXR1  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K1,N)
     &                - NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K2,N)
              NXR2  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K2,N)
     &                + NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K1,N)
              PXR1  =   PCON(K1,N,Q) *   SOLB_XNEG(I,O1,K1,N)
     &                - PCON(K2,N,Q) *   SOLB_XNEG(I,O1,K2,N)
              HOM1CR =   NXR1 * T_DELT_EIGEN(K1,N)
     &                 - NXR2 * T_DELT_EIGEN(K2,N)
              HOM2CR = PXR1
              SHOM_CR = SHOM_CR + HOM1CR + HOM2CR
             ENDDO

C  real part homogeneous solution

             SHOM = SHOM_R + SHOM_CR
             L_DOWN(I,Q) = SHOM

C  End loops over Q and I

            ENDDO
          ENDDO

C  End cases

        ENDIF

C  Particular integral linearization
C    Does not exist if thermal only and N > K, K = 0

        IF ( DO_SOLAR_SOURCES .OR.
     &      (DO_INCLUDE_THERMEMISS.AND.N.EQ.NV) .OR.
     &      (DO_INCLUDE_THERMEMISS.AND.NV.EQ.0) ) THEN
          DO I = 1, NSTREAMS
            DO Q = 1, NV_PARAMETERS
              L_DOWN(I,Q) = L_DOWN(I,Q) + L_WLOWER(I,O1,N,Q)
            ENDDO
          ENDDO
        ENDIF

C  reflectance integrand  a(j).x(j).L_DOWN(-j)

        DO Q = 1, NV_PARAMETERS
          DO I = 1, NSTREAMS
            L_DOWN(I,Q) = L_DOWN(I,Q) * QUAD_STRMWTS(I)
          ENDDO
        ENDDO

C  Continuation point

 5432   CONTINUE

C  ###### Lambertian reflectance (same for all user-streams)

        IF ( FOURIER_COMPONENT .EQ. 0 ) THEN
          KMULT = SURFACE_FACTOR * LAMBERTIAN_ALBEDO
          O1 = 1
          DO Q = 1, NV_PARAMETERS
            REFLEC = ZERO
            DO J = 1, NSTREAMS
              REFLEC = REFLEC + L_DOWN(J,Q)
            ENDDO
            REFLEC = KMULT * REFLEC
            DO UM = LOCAL_UM_START, N_USER_STREAMS
              L_BOA_MSSOURCE(UM,O1,Q) = L_BOA_MSSOURCE(UM,O1,Q)
     &                             + REFLEC
            ENDDO
            IF ( DO_QTHTONLY ) THEN
              DO I = 1, NSTREAMS
                 L_BOA_THTONLY_SOURCE(I,Q) =
     &               L_BOA_THTONLY_SOURCE(I,Q) + REFLEC
              ENDDO
            ENDIF
          ENDDO
        ENDIF

C  Add direct beam if flagged
C    For NV > 0, profile weighting functions
C    For NV = 0, Bulk (column) weighting functions

        IF ( DO_INCLUDE_DIRECTBEAM.AND..NOT.DO_DBCORRECTION ) THEN
          IF ( NV .NE. 0 ) THEN
            DO UM = LOCAL_UM_START, N_USER_STREAMS
              DO O1 = 1, NSTOKES
                FAC = - USER_DIRECT_BEAM(UM,IB,O1)*DELTAU_SLANT(N,NV,IB)
                DO Q = 1, NV_PARAMETERS
                  L_BEAM = L_DELTAU_VERT(Q,NV) * FAC
                  L_BOA_DBSOURCE(UM,O1,Q) = L_BEAM
                ENDDO
              ENDDO
            ENDDO
          ELSE
            DO UM = LOCAL_UM_START, N_USER_STREAMS
              DO O1 = 1, NSTOKES
                FAC = - USER_DIRECT_BEAM(UM,IB,O1)
                DO Q = 1, NV_PARAMETERS
                  L_BEAM = ZERO
                  DO K1 = 1, N
                    L_BEAM = L_BEAM + L_DELTAU_VERT(Q,K1)
     &                               * DELTAU_SLANT(N,K1,IB)
                   ENDDO
                  L_BOA_DBSOURCE(UM,O1,Q) = L_BEAM * FAC
                ENDDO
              ENDDO
            ENDDO
          ENDIF
        ENDIF

C  End inclusion of surface terms

      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE L_WHOLELAYER_STERM_UP
     I       ( M, IBEAM, GIVEN_LAYER, SOURCETERM_FLAG,
     I         LAYER_TO_VARY, NV_PARAMETERS, DO_INCLUDE_THERMEMISS,
     O         L_LAYERSOURCE )

C  Include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of ssolution and multiplier variables (input)

      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  include files of linearized multiplier and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_L_THERMALSUP.VARS'

C  Subroutine input arguments
C  --------------------------

C  Fourier term (debug only)

      INTEGER          M

C  Flag

      LOGICAL          SOURCETERM_FLAG

C  Indices

      INTEGER          IBEAM, GIVEN_LAYER

C  Linearization control

      INTEGER          LAYER_TO_VARY, NV_PARAMETERS

C  Thermal control

      LOGICAL          DO_INCLUDE_THERMEMISS

C  Subroutine output argument
C  --------------------------

      DOUBLE PRECISION L_LAYERSOURCE
     &          ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )

C  local variables
C  ---------------

      INTEGER          N, NV, UM, O1, Q, IB
      INTEGER          K, KO1, K0, K1, K2
      DOUBLE PRECISION SHOM_R, SHOM_CR, SPAR, H1, H2, TM
      DOUBLE PRECISION LUXR, MUXR, NUXR, PUXR, LLUXR, MLUXR
      DOUBLE PRECISION LUXR1, MUXR1, NUXR1, PUXR1, LLUXR1, MLUXR1
      DOUBLE PRECISION LUXR2, MUXR2, NUXR2, PUXR2, LLUXR2, MLUXR2

C   Very important to zero both output terms (bug solved 12/29/05)

      DO Q = 1, NV_PARAMETERS
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            L_LAYERSOURCE(UM,O1,Q)  = ZERO
          ENDDO
       ENDDO
      ENDDO

!  Need to go on if thermal transmittances only
!      IF ( .NOT. SOURCETERM_FLAG ) RETURN

C  local indices

      N   = GIVEN_LAYER
      KO1 = K_REAL(N) + 1
      NV  = LAYER_TO_VARY
      IB  = IBEAM

C  Avoid this section if thermal transmittance only

      IF ( DO_THERMAL_TRANSONLY ) GO TO 6789

C  Homogeneous solutions
C  =====================

C  Special case when N = NV, or NV = 0 (bulk)
C  ------------------------------------------

      IF ( N .EQ. NV .OR. NV.EQ.0 ) THEN

C  Loop over user angles and STokes

        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES

C  parameter loop

           DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

            SHOM_R = ZERO
            DO K = 1, K_REAL(N)
              LUXR  = LCON(K,N)   *   UHOM_UPDN(UM,O1,K,N)
              MUXR  = MCON(K,N)   *   UHOM_UPUP(UM,O1,K,N)
              LLUXR = LCON(K,N)   * L_UHOM_UPDN(UM,O1,K,N,Q)
              MLUXR = MCON(K,N)   * L_UHOM_UPUP(UM,O1,K,N,Q)
              NUXR  = NCON(K,N,Q) *   UHOM_UPDN(UM,O1,K,N)
              PUXR  = PCON(K,N,Q) *   UHOM_UPUP(UM,O1,K,N)
              H1 = ( NUXR + LLUXR ) *   HMULT_2(K,UM,N)
     &                   +  LUXR    * L_HMULT_2(K,UM,N,Q)
              H2 = ( PUXR + MLUXR ) *   HMULT_1(K,UM,N)
     &                   +  MUXR    * L_HMULT_1(K,UM,N,Q)
              SHOM_R = SHOM_R + H1 + H2
            ENDDO

C  Complex homogeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(N)
              K0 = 2*K-2
              K1 = KO1 + K0
              K2 = K1  + 1

              LUXR1 =  LCON(K1,N)   *   UHOM_UPDN(UM,O1,K1,N) -
     &                 LCON(K2,N)   *   UHOM_UPDN(UM,O1,K2,N)
              LUXR2 =  LCON(K1,N)   *   UHOM_UPDN(UM,O1,K2,N) +
     &                 LCON(K2,N)   *   UHOM_UPDN(UM,O1,K1,N)
              MUXR1 =  MCON(K1,N)   *   UHOM_UPUP(UM,O1,K1,N) -
     &                 MCON(K2,N)   *   UHOM_UPUP(UM,O1,K2,N)
              MUXR2 =  MCON(K1,N)   *   UHOM_UPUP(UM,O1,K2,N) +
     &                 MCON(K2,N)   *   UHOM_UPUP(UM,O1,K1,N)

              LLUXR1 = LCON(K1,N)   * L_UHOM_UPDN(UM,O1,K1,N,Q) -
     &                 LCON(K2,N)   * L_UHOM_UPDN(UM,O1,K2,N,Q)
              LLUXR2 = LCON(K1,N)   * L_UHOM_UPDN(UM,O1,K2,N,Q) +
     &                 LCON(K2,N)   * L_UHOM_UPDN(UM,O1,K1,N,Q)
              MLUXR1 = MCON(K1,N)   * L_UHOM_UPUP(UM,O1,K1,N,Q) -
     &                 MCON(K2,N)   * L_UHOM_UPUP(UM,O1,K2,N,Q)
              MLUXR2 = MCON(K1,N)   * L_UHOM_UPUP(UM,O1,K2,N,Q) +
     &                 MCON(K2,N)   * L_UHOM_UPUP(UM,O1,K1,N,Q)

              NUXR1 =  NCON(K1,N,Q) *   UHOM_UPDN(UM,O1,K1,N) -
     &                 NCON(K2,N,Q) *   UHOM_UPDN(UM,O1,K2,N)
              NUXR2 =  NCON(K1,N,Q) *   UHOM_UPDN(UM,O1,K2,N) +
     &                 NCON(K2,N,Q) *   UHOM_UPDN(UM,O1,K1,N)
              PUXR1 =  PCON(K1,N,Q) *   UHOM_UPUP(UM,O1,K1,N) -
     &                 PCON(K2,N,Q) *   UHOM_UPUP(UM,O1,K2,N)
              PUXR2 =  PCON(K1,N,Q) *   UHOM_UPUP(UM,O1,K2,N) +
     &                 PCON(K2,N,Q) *   UHOM_UPUP(UM,O1,K1,N)

              H1 =    ( NUXR1 + LLUXR1 ) * HMULT_2(K1,UM,N)
     &              - ( NUXR2 + LLUXR2 ) * HMULT_2(K2,UM,N)
     &                    +  LUXR1       * L_HMULT_2(K1,UM,N,Q)
     &                    -  LUXR2       * L_HMULT_2(K2,UM,N,Q)
              H2 =    ( PUXR1 + MLUXR1 ) * HMULT_1(K1,UM,N)
     &              - ( PUXR2 + MLUXR2 ) * HMULT_1(K2,UM,N)
     &                    +  MUXR1       * L_HMULT_1(K1,UM,N,Q)
     &                    -  MUXR2       * L_HMULT_1(K2,UM,N,Q)

              SHOM_CR = SHOM_CR + H1 + H2

            ENDDO

C  homogeneous contribution

            L_LAYERSOURCE(UM,O1,Q) = SHOM_R + SHOM_CR
           ENDDO
          ENDDO
        ENDDO

C  Other cases when N not equal to NV (only variation of Integ-Cons)
C  ----------------------------------

      ELSE IF ( N.NE.NV .AND. NV.NE.0 ) THEN

C  Loop over user angles and STokes

        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES

C  parameter loop

           DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

            SHOM_R = ZERO
            DO K = 1, K_REAL(N)
              NUXR  = NCON(K,N,Q) *   UHOM_UPDN(UM,O1,K,N)
              PUXR  = PCON(K,N,Q) *   UHOM_UPUP(UM,O1,K,N)
              H1 = NUXR *   HMULT_2(K,UM,N)
              H2 = PUXR *   HMULT_1(K,UM,N)
              SHOM_R = SHOM_R + H1 + H2
            ENDDO

C  Complex homogeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(N)
              K0 = 2*K-2
              K1 = KO1 + K0
              K2 = K1  + 1
              NUXR1 =  NCON(K1,N,Q) *   UHOM_UPDN(UM,O1,K1,N) -
     &                 NCON(K2,N,Q) *   UHOM_UPDN(UM,O1,K2,N)
              NUXR2 =  NCON(K1,N,Q) *   UHOM_UPDN(UM,O1,K2,N) +
     &                 NCON(K2,N,Q) *   UHOM_UPDN(UM,O1,K1,N)
              PUXR1 =  PCON(K1,N,Q) *   UHOM_UPUP(UM,O1,K1,N) -
     &                 PCON(K2,N,Q) *   UHOM_UPUP(UM,O1,K2,N)
              PUXR2 =  PCON(K1,N,Q) *   UHOM_UPUP(UM,O1,K2,N) +
     &                 PCON(K2,N,Q) *   UHOM_UPUP(UM,O1,K1,N)

              H1 =    NUXR1 * HMULT_2(K1,UM,N)
     &              - NUXR2 * HMULT_2(K2,UM,N)
              H2 =    PUXR1 * HMULT_1(K1,UM,N)
     &              - PUXR2 * HMULT_1(K2,UM,N)

              SHOM_CR = SHOM_CR + H1 + H2
            ENDDO

C  homogeneous contribution

            L_LAYERSOURCE(UM,O1,Q) = SHOM_R + SHOM_CR

C  End loops over Q, O1 and UM

           ENDDO
          ENDDO
        ENDDO

      ENDIF

C  Continuation point

 6789 continue

C  Add thermal emission term (direct and diffuse)
C     -----Modulus 1 if solar sources are included (taken care of earlier)
C     ----- Linearization only exists if N = K

      IF ( DO_INCLUDE_THERMEMISS ) THEN
        O1 = 1
        TM = ONE
        IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
            DO Q = 1, NV_PARAMETERS
              L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q)
     &               + L_LAYER_TSUP_UP(UM,N,Q)*TM
            ENDDO
          ENDDO
        ENDIF
      ENDIF

C  nothing more to do is no solar sources

      IF ( .NOT. DO_SOLAR_SOURCES ) RETURN

C  Particular and single scatter contributions
C  ===========================================

C  Special case when N = NV, or NV = 0 (bulk)
C  ------------------------------------------

      IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN

C  add particular solution

        DO UM = LOCAL_UM_START, N_USER_STREAMS
         DO O1 = 1, NSTOKES
          DO Q = 1, NV_PARAMETERS
           SPAR = L_UPAR_UP_2(UM,O1,N,NV,Q) *   EMULT_UP(UM,N,IB) +
     &              UPAR_UP_2(UM,O1,N)      * L_EMULT_UP(UM,N,NV,IB,Q)
           L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SPAR
          ENDDO
         ENDDO
        ENDDO

C  Add single scatter term if flagged

        IF ( .NOT. DO_MSMODE_VLIDORT ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
           DO O1 = 1, NSTOKES
            DO Q = 1, NV_PARAMETERS
             SPAR = L_UPAR_UP_1(UM,O1,N,Q) *   EMULT_UP(UM,N,IB) +
     &                UPAR_UP_1(UM,O1,N)   * L_EMULT_UP(UM,N,NV,IB,Q)
             L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SPAR
            ENDDO
           ENDDO
          ENDDO
        ENDIF

C  Other cases when N > NV
C  -----------------------

      ELSE IF ( N .GT. NV .AND. NV.NE.0 ) THEN

C  add particular solution

        DO UM = LOCAL_UM_START, N_USER_STREAMS
         DO O1 = 1, NSTOKES
          DO Q = 1, NV_PARAMETERS
           SPAR = L_UPAR_UP_2(UM,O1,N,NV,Q) *   EMULT_UP(UM,N,IB) +
     &              UPAR_UP_2(UM,O1,N)      * L_EMULT_UP(UM,N,NV,IB,Q)
           L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SPAR
          ENDDO
         ENDDO
        ENDDO

C  Add single scatter term if flagged

        IF ( .NOT. DO_MSMODE_VLIDORT ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
           DO O1 = 1, NSTOKES
            DO Q = 1, NV_PARAMETERS
             SPAR =  UPAR_UP_1(UM,O1,N) * L_EMULT_UP(UM,N,NV,IB,Q)
             L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SPAR
            ENDDO
           ENDDO
          ENDDO
        ENDIF

C  End layer clause

      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE L_WHOLELAYER_STERM_DN
     I       ( IBEAM, GIVEN_LAYER, SOURCETERM_FLAG,
     I         LAYER_TO_VARY, NV_PARAMETERS, DO_INCLUDE_THERMEMISS,
     O         L_LAYERSOURCE )

C  Include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of ssolution and multiplier variables (input)

      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  include files of linearized multiplier and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_L_THERMALSUP.VARS'

C  Subroutine input arguments
C  --------------------------

C  Flag

      LOGICAL          SOURCETERM_FLAG

C  Indices

      INTEGER          IBEAM, GIVEN_LAYER

C  Linearization control

      INTEGER          LAYER_TO_VARY, NV_PARAMETERS

C  Thermal control

      LOGICAL          DO_INCLUDE_THERMEMISS

C  Subroutine output argument
C  --------------------------

      DOUBLE PRECISION L_LAYERSOURCE
     &          ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )

C  local variables
C  ---------------

      INTEGER          N, NV, UM, O1, Q, IB
      INTEGER          K, KO1, K0, K1, K2
      DOUBLE PRECISION SHOM_R, SHOM_CR, SPAR, H1, H2, TM
      DOUBLE PRECISION LUXR, MUXR, NUXR, PUXR, LLUXR, MLUXR
      DOUBLE PRECISION LUXR1, MUXR1, NUXR1, PUXR1, LLUXR1, MLUXR1
      DOUBLE PRECISION LUXR2, MUXR2, NUXR2, PUXR2, LLUXR2, MLUXR2

C   Very important to zero both output terms (bug solved 12/29/05)

      DO Q = 1, NV_PARAMETERS
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            L_LAYERSOURCE(UM,O1,Q)       = ZERO
          ENDDO
        ENDDO
      ENDDO

!  Need to go on if thermal transmittances only
!      IF ( .NOT. SOURCETERM_FLAG ) RETURN

C  local indices

      N   = GIVEN_LAYER
      KO1 = K_REAL(N) + 1
      NV  = LAYER_TO_VARY
      IB  = IBEAM

C  Avoid this section if thermal transmittance only

      IF ( DO_THERMAL_TRANSONLY ) GO TO 6789

C  Homogeneous solutions
C  =====================

C  Special case when N = NV, or NV = 0 (bulk)
C  ------------------------------------------

      IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN

C  Loop over user angles and STokes

        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES

C  parameter loop

           DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

            SHOM_R = ZERO
            DO K = 1, K_REAL(N)
              LUXR  = LCON(K,N)   *   UHOM_DNDN(UM,O1,K,N)
              MUXR  = MCON(K,N)   *   UHOM_DNUP(UM,O1,K,N)
              LLUXR = LCON(K,N)   * L_UHOM_DNDN(UM,O1,K,N,Q)
              MLUXR = MCON(K,N)   * L_UHOM_DNUP(UM,O1,K,N,Q)
              NUXR  = NCON(K,N,Q) *   UHOM_DNDN(UM,O1,K,N)
              PUXR  = PCON(K,N,Q) *   UHOM_DNUP(UM,O1,K,N)
              H1 = ( NUXR + LLUXR ) *   HMULT_1(K,UM,N)
     &                   +  LUXR    * L_HMULT_1(K,UM,N,Q)
              H2 = ( PUXR + MLUXR ) *   HMULT_2(K,UM,N)
     &                   +  MUXR    * L_HMULT_2(K,UM,N,Q)
              SHOM_R = SHOM_R + H1 + H2
            ENDDO

C  Complex homogeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(N)
              K0 = 2*K-2
              K1 = KO1 + K0
              K2 = K1  + 1

              LUXR1 =  LCON(K1,N)   *   UHOM_DNDN(UM,O1,K1,N) -
     &                 LCON(K2,N)   *   UHOM_DNDN(UM,O1,K2,N)
              LUXR2 =  LCON(K1,N)   *   UHOM_DNDN(UM,O1,K2,N) +
     &                 LCON(K2,N)   *   UHOM_DNDN(UM,O1,K1,N)
              MUXR1 =  MCON(K1,N)   *   UHOM_DNUP(UM,O1,K1,N) -
     &                 MCON(K2,N)   *   UHOM_DNUP(UM,O1,K2,N)
              MUXR2 =  MCON(K1,N)   *   UHOM_DNUP(UM,O1,K2,N) +
     &                 MCON(K2,N)   *   UHOM_DNUP(UM,O1,K1,N)

              LLUXR1 = LCON(K1,N)   * L_UHOM_DNDN(UM,O1,K1,N,Q) -
     &                 LCON(K2,N)   * L_UHOM_DNDN(UM,O1,K2,N,Q)
              LLUXR2 = LCON(K1,N)   * L_UHOM_DNDN(UM,O1,K2,N,Q) +
     &                 LCON(K2,N)   * L_UHOM_DNDN(UM,O1,K1,N,Q)
              MLUXR1 = MCON(K1,N)   * L_UHOM_DNUP(UM,O1,K1,N,Q) -
     &                 MCON(K2,N)   * L_UHOM_DNUP(UM,O1,K2,N,Q)
              MLUXR2 = MCON(K1,N)   * L_UHOM_DNUP(UM,O1,K2,N,Q) +
     &                 MCON(K2,N)   * L_UHOM_DNUP(UM,O1,K1,N,Q)

              NUXR1 =  NCON(K1,N,Q) *   UHOM_DNDN(UM,O1,K1,N) -
     &                 NCON(K2,N,Q) *   UHOM_DNDN(UM,O1,K2,N)
              NUXR2 =  NCON(K1,N,Q) *   UHOM_DNDN(UM,O1,K2,N) +
     &                 NCON(K2,N,Q) *   UHOM_DNDN(UM,O1,K1,N)
              PUXR1 =  PCON(K1,N,Q) *   UHOM_DNUP(UM,O1,K1,N) -
     &                 PCON(K2,N,Q) *   UHOM_DNUP(UM,O1,K2,N)
              PUXR2 =  PCON(K1,N,Q) *   UHOM_DNUP(UM,O1,K2,N) +
     &                 PCON(K2,N,Q) *   UHOM_DNUP(UM,O1,K1,N)

              H1 =    ( NUXR1 + LLUXR1 ) * HMULT_1(K1,UM,N)
     &              - ( NUXR2 + LLUXR2 ) * HMULT_1(K2,UM,N)
     &                    +  LUXR1       * L_HMULT_1(K1,UM,N,Q)
     &                    -  LUXR2       * L_HMULT_1(K2,UM,N,Q)
              H2 =    ( PUXR1 + MLUXR1 ) * HMULT_2(K1,UM,N)
     &              - ( PUXR2 + MLUXR2 ) * HMULT_2(K2,UM,N)
     &                    +  MUXR1       * L_HMULT_2(K1,UM,N,Q)
     &                    -  MUXR2       * L_HMULT_2(K2,UM,N,Q)

              SHOM_CR = SHOM_CR + H1 + H2

            ENDDO

C  homogeneous contribution

            L_LAYERSOURCE(UM,O1,Q) = SHOM_R + SHOM_CR

C  End loops over Q, O1 and UM

           ENDDO
          ENDDO
        ENDDO

C  Other cases when N not equal to NV (only variation of Integ-Cons)
C  ----------------------------------

      ELSE IF ( NV.NE.0 .AND. N.NE.NV ) THEN

C  Loop over user angles and STokes

        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES

C  parameter loop

           DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

            SHOM_R = ZERO
            DO K = 1, K_REAL(N)
              NUXR  = NCON(K,N,Q) *   UHOM_DNDN(UM,O1,K,N)
              PUXR  = PCON(K,N,Q) *   UHOM_DNUP(UM,O1,K,N)
              H1 = NUXR * HMULT_1(K,UM,N)
              H2 = PUXR * HMULT_2(K,UM,N)
              SHOM_R = SHOM_R + H1 + H2
            ENDDO

C  Complex homogeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(N)
              K0 = 2*K-2
              K1 = KO1 + K0
              K2 = K1  + 1

              NUXR1 =  NCON(K1,N,Q) *   UHOM_DNDN(UM,O1,K1,N) -
     &                 NCON(K2,N,Q) *   UHOM_DNDN(UM,O1,K2,N)
              NUXR2 =  NCON(K1,N,Q) *   UHOM_DNDN(UM,O1,K2,N) +
     &                 NCON(K2,N,Q) *   UHOM_DNDN(UM,O1,K1,N)
              PUXR1 =  PCON(K1,N,Q) *   UHOM_DNUP(UM,O1,K1,N) -
     &                 PCON(K2,N,Q) *   UHOM_DNUP(UM,O1,K2,N)
              PUXR2 =  PCON(K1,N,Q) *   UHOM_DNUP(UM,O1,K2,N) +
     &                 PCON(K2,N,Q) *   UHOM_DNUP(UM,O1,K1,N)

              H1 =     NUXR1 * HMULT_1(K1,UM,N)
     &              -  NUXR2 * HMULT_1(K2,UM,N)
              H2 =     PUXR1 * HMULT_2(K1,UM,N)
     &              -  PUXR2 * HMULT_2(K2,UM,N)

              SHOM_CR = SHOM_CR + H1 + H2

            ENDDO

C  homogeneous contribution

            L_LAYERSOURCE(UM,O1,Q) = SHOM_R + SHOM_CR

C  End loops over Q, O1 and UM

           ENDDO
          ENDDO
        ENDDO

C  End layer clause

      ENDIF

C  Continuation point

 6789 continue

C  Add thermal emission term (direct and diffuse)
C     ----- Modulus 1 if solar sources are included (taken care of earlier)
C     ----- Linearization only exists if N = K, or K = 0 (bulk)

      IF ( DO_INCLUDE_THERMEMISS ) THEN
        O1 = 1
        TM = ONE
        IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
            DO Q = 1, NV_PARAMETERS
              L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q)
     &               + L_LAYER_TSUP_DN(UM,N,Q)*TM
            ENDDO
          ENDDO
        ENDIF
      ENDIF

C  nothing more to do is no solar sources

      IF ( .NOT. DO_SOLAR_SOURCES ) RETURN

C  Particular and single scatter contributions
C  ===========================================

C  Special case when N = NV, or NV = 0 (bulk)
C  -----------------------------------------

      IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN

C  add particular solution

        DO UM = LOCAL_UM_START, N_USER_STREAMS
         DO O1 = 1, NSTOKES
          DO Q = 1, NV_PARAMETERS
           SPAR = L_UPAR_DN_2(UM,O1,N,NV,Q) *   EMULT_DN(UM,N,IB) +
     &              UPAR_DN_2(UM,O1,N)      * L_EMULT_DN(UM,N,NV,IB,Q)
           L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SPAR
          ENDDO
         ENDDO
        ENDDO

C  Add single scatter term if flagged

        IF ( .NOT. DO_MSMODE_VLIDORT ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
           DO O1 = 1, NSTOKES
            DO Q = 1, NV_PARAMETERS
             SPAR = L_UPAR_DN_1(UM,O1,N,Q) *   EMULT_DN(UM,N,IB) +
     &                UPAR_DN_1(UM,O1,N)   * L_EMULT_DN(UM,N,NV,IB,Q)
             L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SPAR
            ENDDO
           ENDDO
          ENDDO
        ENDIF

C  Other cases when N > NV
C  -----------------------

      ELSE IF ( N.GT.NV .AND. NV.NE.0) THEN

C  add particular solution

        DO UM = LOCAL_UM_START, N_USER_STREAMS
         DO O1 = 1, NSTOKES
          DO Q = 1, NV_PARAMETERS
          SPAR = L_UPAR_DN_2(UM,O1,N,NV,Q) *   EMULT_DN(UM,N,IB) +
     &             UPAR_DN_2(UM,O1,N)      * L_EMULT_DN(UM,N,NV,IB,Q)
          L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SPAR
          ENDDO
         ENDDO
        ENDDO

C  Add single scatter term if flagged

        IF ( .NOT. DO_MSMODE_VLIDORT ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
           DO O1 = 1, NSTOKES
            DO Q = 1, NV_PARAMETERS
             SPAR =  UPAR_DN_1(UM,O1,N) * L_EMULT_DN(UM,N,NV,IB,Q)
             L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SPAR
            ENDDO
           ENDDO
          ENDDO
        ENDIF

C  End layer clause

      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE L_PARTLAYER_STERM_UP
     I       ( IBEAM, OFFGRID_INDEX, GIVEN_LAYER, SOURCETERM_FLAG,
     I         LAYER_TO_VARY, NV_PARAMETERS, DO_INCLUDE_THERMEMISS,
     O         L_LAYERSOURCE )

C  Include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of ssolution and multiplier variables (input)

      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  include files of linearized multiplier and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_L_THERMALSUP.VARS'

C  Subroutine input arguments
C  --------------------------

C  Flag

      LOGICAL          SOURCETERM_FLAG

C  layer and beam index

      INTEGER          GIVEN_LAYER, IBEAM

C  offgrid optical depth index

      INTEGER          OFFGRID_INDEX

C  Linearization control

      INTEGER          LAYER_TO_VARY, NV_PARAMETERS

C  Thermal control

      LOGICAL          DO_INCLUDE_THERMEMISS

C  Subroutine output argument
C  --------------------------

      DOUBLE PRECISION L_LAYERSOURCE
     &          ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )

C  local variables
C  ---------------

      INTEGER          N, NV, UM, O1, Q, IB, UT
      INTEGER          K, KO1, K0, K1, K2
      DOUBLE PRECISION SHOM_R, SHOM_CR, SP, H1, H2, TM
      DOUBLE PRECISION LUXR, MUXR, NUXR, PUXR, LLUXR, MLUXR
      DOUBLE PRECISION LUXR1, MUXR1, NUXR1, PUXR1, LLUXR1, MLUXR1
      DOUBLE PRECISION LUXR2, MUXR2, NUXR2, PUXR2, LLUXR2, MLUXR2

C   Very important to zero both output terms (bug solved 12/29/05)

      DO Q = 1, NV_PARAMETERS
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            L_LAYERSOURCE(UM,O1,Q)       = ZERO
          ENDDO
        ENDDO
      ENDDO

!  Need to go on if thermal transmittances only
!      IF ( .NOT. SOURCETERM_FLAG ) RETURN

C  local indices

      N   = GIVEN_LAYER
      KO1 = K_REAL(N) + 1
      NV  = LAYER_TO_VARY
      UT  = OFFGRID_INDEX
      IB = IBEAM

C  Avoid this section if thermal transmittance only

      IF ( DO_THERMAL_TRANSONLY ) GO TO 6789

C  Partial layer source function ( Homogeneous/constants variation )
C  =================================================================

C  Special case when N = NV, or NV = 0 (bulk)
C  ------------------------------------------

      IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN

C  Loop over user angles and STokes

        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES

C  parameter loop

           DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

            SHOM_R = ZERO
            DO K = 1, K_REAL(N)

              LUXR  = LCON(K,N)   *   UHOM_UPDN(UM,O1,K,N)
              MUXR  = MCON(K,N)   *   UHOM_UPUP(UM,O1,K,N)
              LLUXR = LCON(K,N)   * L_UHOM_UPDN(UM,O1,K,N,Q)
              MLUXR = MCON(K,N)   * L_UHOM_UPUP(UM,O1,K,N,Q)
              NUXR  = NCON(K,N,Q) *   UHOM_UPDN(UM,O1,K,N)
              PUXR  = PCON(K,N,Q) *   UHOM_UPUP(UM,O1,K,N)

              H1 = ( NUXR + LLUXR ) *   UT_HMULT_UD(K,UM,UT)
     &                   +  LUXR    * L_UT_HMULT_UD(K,UM,UT,Q)
              H2 = ( PUXR + MLUXR ) *   UT_HMULT_UU(K,UM,UT)
     &                   +  MUXR    * L_UT_HMULT_UU(K,UM,UT,Q)
              SHOM_R = SHOM_R + H1 + H2

            ENDDO

C  Complex homogeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(N)
              K0 = 2*K-2
              K1 = KO1 + K0
              K2 = K1  + 1

              LUXR1 =  LCON(K1,N)   *   UHOM_UPDN(UM,O1,K1,N) -
     &                 LCON(K2,N)   *   UHOM_UPDN(UM,O1,K2,N)
              LUXR2 =  LCON(K1,N)   *   UHOM_UPDN(UM,O1,K2,N) +
     &                 LCON(K2,N)   *   UHOM_UPDN(UM,O1,K1,N)
              MUXR1 =  MCON(K1,N)   *   UHOM_UPUP(UM,O1,K1,N) -
     &                 MCON(K2,N)   *   UHOM_UPUP(UM,O1,K2,N)
              MUXR2 =  MCON(K1,N)   *   UHOM_UPUP(UM,O1,K2,N) +
     &                 MCON(K2,N)   *   UHOM_UPUP(UM,O1,K1,N)

              LLUXR1 = LCON(K1,N)   * L_UHOM_UPDN(UM,O1,K1,N,Q) -
     &                 LCON(K2,N)   * L_UHOM_UPDN(UM,O1,K2,N,Q)
              LLUXR2 = LCON(K1,N)   * L_UHOM_UPDN(UM,O1,K2,N,Q) +
     &                 LCON(K2,N)   * L_UHOM_UPDN(UM,O1,K1,N,Q)
              MLUXR1 = MCON(K1,N)   * L_UHOM_UPUP(UM,O1,K1,N,Q) -
     &                 MCON(K2,N)   * L_UHOM_UPUP(UM,O1,K2,N,Q)
              MLUXR2 = MCON(K1,N)   * L_UHOM_UPUP(UM,O1,K2,N,Q) +
     &                 MCON(K2,N)   * L_UHOM_UPUP(UM,O1,K1,N,Q)

              NUXR1 =  NCON(K1,N,Q) *   UHOM_UPDN(UM,O1,K1,N) -
     &                 NCON(K2,N,Q) *   UHOM_UPDN(UM,O1,K2,N)
              NUXR2 =  NCON(K1,N,Q) *   UHOM_UPDN(UM,O1,K2,N) +
     &                 NCON(K2,N,Q) *   UHOM_UPDN(UM,O1,K1,N)
              PUXR1 =  PCON(K1,N,Q) *   UHOM_UPUP(UM,O1,K1,N) -
     &                 PCON(K2,N,Q) *   UHOM_UPUP(UM,O1,K2,N)
              PUXR2 =  PCON(K1,N,Q) *   UHOM_UPUP(UM,O1,K2,N) +
     &                 PCON(K2,N,Q) *   UHOM_UPUP(UM,O1,K1,N)

              H1 =    ( NUXR1 + LLUXR1 ) * UT_HMULT_UD(K1,UM,UT)
     &              - ( NUXR2 + LLUXR2 ) * UT_HMULT_UD(K2,UM,UT)
     &                    +  LUXR1       * L_UT_HMULT_UD(K1,UM,UT,Q)
     &                    -  LUXR2       * L_UT_HMULT_UD(K2,UM,UT,Q)
              H2 =    ( PUXR1 + MLUXR1 ) * UT_HMULT_UU(K1,UM,UT)
     &              - ( PUXR2 + MLUXR2 ) * UT_HMULT_UU(K2,UM,UT)
     &                    +  MUXR1       * L_UT_HMULT_UU(K1,UM,UT,Q)
     &                    -  MUXR2       * L_UT_HMULT_UU(K2,UM,UT,Q)

              SHOM_CR = SHOM_CR + H1 + H2

            ENDDO

C  homogeneous contribution

            L_LAYERSOURCE(UM,O1,Q) = SHOM_R + SHOM_CR

C  End loops over Q, O1 and UM

           ENDDO
          ENDDO
        ENDDO

C  Other cases when N not equal to NV (only variation of Integ-Cons)
C  ----------------------------------

      ELSE IF ( N.NE.NV .AND. NV.NE.0 ) THEN

C  Loop over user angles and STokes

        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES

C  parameter loop

           DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

            SHOM_R = ZERO
            DO K = 1, K_REAL(N)
              NUXR  = NCON(K,N,Q) *   UHOM_UPDN(UM,O1,K,N)
              PUXR  = PCON(K,N,Q) *   UHOM_UPUP(UM,O1,K,N)
              H1 = NUXR *   UT_HMULT_UD(K,UM,UT)
              H2 = PUXR *   UT_HMULT_UU(K,UM,UT)
              SHOM_R = SHOM_R + H1 + H2
            ENDDO

C  Complex homogeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(N)
              K0 = 2*K-2
              K1 = KO1 + K0
              K2 = K1  + 1

              NUXR1 =  NCON(K1,N,Q) *   UHOM_UPDN(UM,O1,K1,N) -
     &                 NCON(K2,N,Q) *   UHOM_UPDN(UM,O1,K2,N)
              NUXR2 =  NCON(K1,N,Q) *   UHOM_UPDN(UM,O1,K2,N) +
     &                 NCON(K2,N,Q) *   UHOM_UPDN(UM,O1,K1,N)
              PUXR1 =  PCON(K1,N,Q) *   UHOM_UPUP(UM,O1,K1,N) -
     &                 PCON(K2,N,Q) *   UHOM_UPUP(UM,O1,K2,N)
              PUXR2 =  PCON(K1,N,Q) *   UHOM_UPUP(UM,O1,K2,N) +
     &                 PCON(K2,N,Q) *   UHOM_UPUP(UM,O1,K1,N)

              H1 =    NUXR1 * UT_HMULT_UD(K1,UM,UT)
     &              - NUXR2 * UT_HMULT_UD(K2,UM,UT)
              H2 =    PUXR1 * UT_HMULT_UU(K1,UM,UT)
     &              - PUXR2 * UT_HMULT_UU(K2,UM,UT)

              SHOM_CR = SHOM_CR + H1 + H2

            ENDDO

C  homogeneous contribution

            L_LAYERSOURCE(UM,O1,Q) = SHOM_R + SHOM_CR

C  End loops over Q, O1 and UM

           ENDDO
          ENDDO
        ENDDO

C  End layer clause

      ENDIF

C  Continuation point

 6789 continue

C  Add thermal emission term (direct and diffuse)
C     ----- Modulus 1.0 if solar sources are included (taken care of earlier)
C     ----- Linearization only exists if N = K, or K = 0 (bulk)

      IF ( DO_INCLUDE_THERMEMISS ) THEN
        O1 = 1
        TM = ONE
        IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
            DO Q = 1, NV_PARAMETERS
              L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q)
     &               + L_LAYER_TSUP_UTUP(UM,UT,Q)*TM
            ENDDO
          ENDDO
        ENDIF
      ENDIF

C  nothing more to do is no solar sources

      IF ( .NOT. DO_SOLAR_SOURCES ) RETURN

C  Particular and single scatter contributions
C  ===========================================

C  Special case when N = NV, or NV = 0 (bulk)
C  ------------------------------------------

      IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN

C  add particular solution

        DO UM = LOCAL_UM_START, N_USER_STREAMS
         DO O1 = 1, NSTOKES
          DO Q = 1, NV_PARAMETERS
           SP = L_UPAR_UP_2(UM,O1,N,NV,Q) *   UT_EMULT_UP(UM,UT,IB) +
     &            UPAR_UP_2(UM,O1,N)      * L_UT_EMULT_UP(UM,UT,NV,IB,Q)
           L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SP
          ENDDO
         ENDDO
        ENDDO

C  Add single scatter term if flagged

        IF ( .NOT. DO_MSMODE_VLIDORT ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
           DO O1 = 1, NSTOKES
            DO Q = 1, NV_PARAMETERS
             SP = L_UPAR_UP_1(UM,O1,N,Q) *   UT_EMULT_UP(UM,UT,IB) +
     &              UPAR_UP_1(UM,O1,N)   * L_UT_EMULT_UP(UM,UT,NV,IB,Q)
             L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SP
            ENDDO
           ENDDO
          ENDDO
        ENDIF

C  Other cases when N > NV
C  -----------------------

      ELSE IF ( N.GT.NV .AND. NV.NE.0 ) THEN

C  add particular solution

        DO UM = LOCAL_UM_START, N_USER_STREAMS
         DO O1 = 1, NSTOKES
          DO Q = 1, NV_PARAMETERS
           SP = L_UPAR_UP_2(UM,O1,N,NV,Q) *   UT_EMULT_UP(UM,UT,IB) +
     &            UPAR_UP_2(UM,O1,N)      * L_UT_EMULT_UP(UM,UT,NV,IB,Q)
           L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SP
          ENDDO
         ENDDO
        ENDDO

C  Add single scatter term if flagged

        IF ( .NOT. DO_MSMODE_VLIDORT ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
           DO O1 = 1, NSTOKES
            DO Q = 1, NV_PARAMETERS
             SP =  UPAR_UP_1(UM,O1,N) * L_UT_EMULT_UP(UM,UT,NV,IB,Q)
             L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SP
            ENDDO
           ENDDO
          ENDDO
        ENDIF

C  End layer clause

      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE L_PARTLAYER_STERM_DN
     I       ( IBEAM, OFFGRID_INDEX, GIVEN_LAYER, SOURCETERM_FLAG,
     I         LAYER_TO_VARY, NV_PARAMETERS, DO_INCLUDE_THERMEMISS,
     O         L_LAYERSOURCE )

C  Include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of ssolution and multiplier variables (input)

      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  include files of linearized multiplier and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_L_THERMALSUP.VARS'

C  Subroutine input arguments
C  --------------------------

C  Flag

      LOGICAL          SOURCETERM_FLAG

C  layer and beam indices

      INTEGER          GIVEN_LAYER, IBEAM

C  offgrid optical depth index

      INTEGER          OFFGRID_INDEX

C  Linearization control

      INTEGER          LAYER_TO_VARY, NV_PARAMETERS

C  Thermal control

      LOGICAL          DO_INCLUDE_THERMEMISS

C  Subroutine output argument
C  --------------------------

      DOUBLE PRECISION L_LAYERSOURCE
     &          ( MAX_USER_STREAMS, MAXSTOKES, MAX_ATMOSWFS )

C  local variables
C  ---------------

      INTEGER          N, NV, UM, O1, Q, IB, UT
      INTEGER          K, KO1, K0, K1, K2
      DOUBLE PRECISION SHOM_R, SHOM_CR, SP, H1, H2, TM
      DOUBLE PRECISION LUXR, MUXR, NUXR, PUXR, LLUXR, MLUXR
      DOUBLE PRECISION LUXR1, MUXR1, NUXR1, PUXR1, LLUXR1, MLUXR1
      DOUBLE PRECISION LUXR2, MUXR2, NUXR2, PUXR2, LLUXR2, MLUXR2

C   Very important to zero both output terms (bug solved 12/29/05)

      DO Q = 1, NV_PARAMETERS
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            L_LAYERSOURCE(UM,O1,Q)       = ZERO
          ENDDO
        ENDDO
      ENDDO

!  Need to go on if thermal transmittances only
!      IF ( .NOT. SOURCETERM_FLAG ) RETURN

C  local indices

      N   = GIVEN_LAYER
      KO1 = K_REAL(N) + 1
      NV  = LAYER_TO_VARY
      UT  = OFFGRID_INDEX
      IB  = IBEAM

C  Avoid this section if thermal transmittance only

      IF ( DO_THERMAL_TRANSONLY ) GO TO 6789

C  Partial layer source function ( Homogeneous/constants variation )
C  =================================================================

C  Special case when N = NV, or NV = 0 (bulk)
C  ------------------------------------------

      IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN

C  Loop over user angles and STokes

        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES

C  parameter loop

           DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

            SHOM_R = ZERO
            DO K = 1, K_REAL(N)

              LUXR  = LCON(K,N)   *   UHOM_DNDN(UM,O1,K,N)
              MUXR  = MCON(K,N)   *   UHOM_DNUP(UM,O1,K,N)
              LLUXR = LCON(K,N)   * L_UHOM_DNDN(UM,O1,K,N,Q)
              MLUXR = MCON(K,N)   * L_UHOM_DNUP(UM,O1,K,N,Q)
              NUXR  = NCON(K,N,Q) *   UHOM_DNDN(UM,O1,K,N)
              PUXR  = PCON(K,N,Q) *   UHOM_DNUP(UM,O1,K,N)

              H1 = ( NUXR + LLUXR ) *   UT_HMULT_DD(K,UM,UT)
     &                   +  LUXR    * L_UT_HMULT_DD(K,UM,UT,Q)
              H2 = ( PUXR + MLUXR ) *   UT_HMULT_DU(K,UM,UT)
     &                   +  MUXR    * L_UT_HMULT_DU(K,UM,UT,Q)
              SHOM_R = SHOM_R + H1 + H2

            ENDDO

C  Complex homogeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(N)
              K0 = 2*K-2
              K1 = KO1 + K0
              K2 = K1  + 1

              LUXR1 =  LCON(K1,N)   *   UHOM_DNDN(UM,O1,K1,N) -
     &                 LCON(K2,N)   *   UHOM_DNDN(UM,O1,K2,N)
              LUXR2 =  LCON(K1,N)   *   UHOM_DNDN(UM,O1,K2,N) +
     &                 LCON(K2,N)   *   UHOM_DNDN(UM,O1,K1,N)
              MUXR1 =  MCON(K1,N)   *   UHOM_DNUP(UM,O1,K1,N) -
     &                 MCON(K2,N)   *   UHOM_DNUP(UM,O1,K2,N)
              MUXR2 =  MCON(K1,N)   *   UHOM_DNUP(UM,O1,K2,N) +
     &                 MCON(K2,N)   *   UHOM_DNUP(UM,O1,K1,N)

              LLUXR1 = LCON(K1,N)   * L_UHOM_DNDN(UM,O1,K1,N,Q) -
     &                 LCON(K2,N)   * L_UHOM_DNDN(UM,O1,K2,N,Q)
              LLUXR2 = LCON(K1,N)   * L_UHOM_DNDN(UM,O1,K2,N,Q) +
     &                 LCON(K2,N)   * L_UHOM_DNDN(UM,O1,K1,N,Q)
              MLUXR1 = MCON(K1,N)   * L_UHOM_DNUP(UM,O1,K1,N,Q) -
     &                 MCON(K2,N)   * L_UHOM_DNUP(UM,O1,K2,N,Q)
              MLUXR2 = MCON(K1,N)   * L_UHOM_DNUP(UM,O1,K2,N,Q) +
     &                 MCON(K2,N)   * L_UHOM_DNUP(UM,O1,K1,N,Q)

              NUXR1 =  NCON(K1,N,Q) *   UHOM_DNDN(UM,O1,K1,N) -
     &                 NCON(K2,N,Q) *   UHOM_DNDN(UM,O1,K2,N)
              NUXR2 =  NCON(K1,N,Q) *   UHOM_DNDN(UM,O1,K2,N) +
     &                 NCON(K2,N,Q) *   UHOM_DNDN(UM,O1,K1,N)
              PUXR1 =  PCON(K1,N,Q) *   UHOM_DNUP(UM,O1,K1,N) -
     &                 PCON(K2,N,Q) *   UHOM_DNUP(UM,O1,K2,N)
              PUXR2 =  PCON(K1,N,Q) *   UHOM_DNUP(UM,O1,K2,N) +
     &                 PCON(K2,N,Q) *   UHOM_DNUP(UM,O1,K1,N)

              H1 =    ( NUXR1 + LLUXR1 ) * UT_HMULT_DD(K1,UM,UT)
     &              - ( NUXR2 + LLUXR2 ) * UT_HMULT_DD(K2,UM,UT)
     &                    +  LUXR1       * L_UT_HMULT_DD(K1,UM,UT,Q)
     &                    -  LUXR2       * L_UT_HMULT_DD(K2,UM,UT,Q)
              H2 =    ( PUXR1 + MLUXR1 ) * UT_HMULT_DU(K1,UM,UT)
     &              - ( PUXR2 + MLUXR2 ) * UT_HMULT_DU(K2,UM,UT)
     &                    +  MUXR1       * L_UT_HMULT_DU(K1,UM,UT,Q)
     &                    -  MUXR2       * L_UT_HMULT_DU(K2,UM,UT,Q)

              SHOM_CR = SHOM_CR + H1 + H2

            ENDDO

C  homogeneous contribution

            L_LAYERSOURCE(UM,O1,Q) = SHOM_R + SHOM_CR

C  End loops over Q, O1 and UM

           ENDDO
          ENDDO
        ENDDO

C  Other cases when N not equal to NV (only variation of Integ-Cons)
C  ----------------------------------

      ELSE IF ( N.NE.NV .AND. NV.NE.0 ) THEN

C  Loop over user angles and STokes

        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES

C  parameter loop

           DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

            SHOM_R = ZERO
            DO K = 1, K_REAL(N)
              NUXR  = NCON(K,N,Q) *   UHOM_DNDN(UM,O1,K,N)
              PUXR  = PCON(K,N,Q) *   UHOM_DNUP(UM,O1,K,N)
              H1 = NUXR *   UT_HMULT_DD(K,UM,UT)
              H2 = PUXR *   UT_HMULT_DU(K,UM,UT)
              SHOM_R = SHOM_R + H1 + H2
            ENDDO

C  Complex homogeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(N)
              K0 = 2*K-2
              K1 = KO1 + K0
              K2 = K1  + 1

              NUXR1 =  NCON(K1,N,Q) *   UHOM_DNDN(UM,O1,K1,N) -
     &                 NCON(K2,N,Q) *   UHOM_DNDN(UM,O1,K2,N)
              NUXR2 =  NCON(K1,N,Q) *   UHOM_DNDN(UM,O1,K2,N) +
     &                 NCON(K2,N,Q) *   UHOM_DNDN(UM,O1,K1,N)
              PUXR1 =  PCON(K1,N,Q) *   UHOM_DNUP(UM,O1,K1,N) -
     &                 PCON(K2,N,Q) *   UHOM_DNUP(UM,O1,K2,N)
              PUXR2 =  PCON(K1,N,Q) *   UHOM_DNUP(UM,O1,K2,N) +
     &                 PCON(K2,N,Q) *   UHOM_DNUP(UM,O1,K1,N)

              H1 =    NUXR1 * UT_HMULT_DD(K1,UM,UT)
     &              - NUXR2 * UT_HMULT_DD(K2,UM,UT)
              H2 =    PUXR1 * UT_HMULT_DU(K1,UM,UT)
     &              - PUXR2 * UT_HMULT_DU(K2,UM,UT)

              SHOM_CR = SHOM_CR + H1 + H2

            ENDDO

C  homogeneous contribution

            L_LAYERSOURCE(UM,O1,Q) = SHOM_R + SHOM_CR

C  End loops over Q, O1 and UM

           ENDDO
          ENDDO
        ENDDO

C  End layer clause

      ENDIF

C  Continuation point

 6789 continue

C  Add thermal emission term (direct and diffuse)
C     ----- Modulus 1.0 if solar sources are included (taken care of earlier)
C     ----- Linearization only exists if N = K, or K = 0 (bulk)

      IF ( DO_INCLUDE_THERMEMISS ) THEN
        O1 = 1
        TM = ONE
        IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
            DO Q = 1, NV_PARAMETERS
              L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q)
     &               + L_LAYER_TSUP_UTDN(UM,UT,Q)*TM
            ENDDO
          ENDDO
        ENDIF
      ENDIF

C  nothing more to do is no solar sources

      IF ( .NOT. DO_SOLAR_SOURCES ) RETURN

C  Particular and single scatter contributions
C  ===========================================

C  Special case when N = NV, or NV = 0 (bulk)
C  ------------------------------------------

      IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN

C  add particular solution

        DO UM = LOCAL_UM_START, N_USER_STREAMS
         DO O1 = 1, NSTOKES
          DO Q = 1, NV_PARAMETERS
           SP = L_UPAR_DN_2(UM,O1,N,NV,Q) *   UT_EMULT_DN(UM,UT,IB) +
     &            UPAR_DN_2(UM,O1,N)      * L_UT_EMULT_DN(UM,UT,NV,IB,Q)
           L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SP
!          if (ut.eq.1)write(*,*)um,q,
!     &        L_UPAR_DN_2(UM,O1,N,NV,Q),L_UT_EMULT_DN(UM,UT,NV,IB,Q)
          ENDDO
         ENDDO
        ENDDO

C  Add single scatter term if flagged

        IF ( .NOT. DO_MSMODE_VLIDORT ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
           DO O1 = 1, NSTOKES
            DO Q = 1, NV_PARAMETERS
             SP = L_UPAR_DN_1(UM,O1,N,Q) *   UT_EMULT_DN(UM,UT,IB) +
     &              UPAR_DN_1(UM,O1,N)   * L_UT_EMULT_DN(UM,UT,NV,IB,Q)
             L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SP
c            write(*,*)ib,n,nv,ut,um,q,'par2'
            ENDDO
           ENDDO
          ENDDO
        ENDIF

C  Other cases when N > NV
C  -----------------------

      ELSE IF ( N.GT.NV .AND. NV.NE.0 ) THEN

C  add particular solution

        DO UM = LOCAL_UM_START, N_USER_STREAMS
         DO O1 = 1, NSTOKES
          DO Q = 1, NV_PARAMETERS
           SP = L_UPAR_DN_2(UM,O1,N,NV,Q) *   UT_EMULT_DN(UM,UT,IB) +
     &            UPAR_DN_2(UM,O1,N)      * L_UT_EMULT_DN(UM,UT,NV,IB,Q)
           L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SP
          ENDDO
         ENDDO
        ENDDO

C  Add single scatter term if flagged

        IF ( .NOT. DO_MSMODE_VLIDORT ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
           DO O1 = 1, NSTOKES
            DO Q = 1, NV_PARAMETERS
             SP =  UPAR_DN_1(UM,O1,N) * L_UT_EMULT_DN(UM,UT,NV,IB,Q)
             L_LAYERSOURCE(UM,O1,Q) = L_LAYERSOURCE(UM,O1,Q) + SP
            ENDDO
           ENDDO
          ENDDO
        ENDIF

C  End layer clause

      ENDIF

C  Finish

      RETURN
      END


      SUBROUTINE FORCE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      PARAMETER (MORB22=MORB2*2, MAXOR2=MAXORB*2)
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR),IDUMY,DUMY(MAXPAR)
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR),
     1                     LOCDEP(MAXPAR)
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /FMATRX/ FMATRX(MAXHES)
      COMMON /KEYWRD/ KEYWRD
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM
      COMMON /VECTOR/ CNORML(MORB22),FREQ(MAXOR2)
      COMMON /GEOM  / GEO(3,NUMATM)
      COMMON /COORD / COORD(3,NUMATM)
***********************************************************************
*
*   FORCE CALCULATES THE FORCE CONSTANTS FOR THE MOLECULE, AND THE
*         VIBRATIONAL FREQUENCIES.  ISOTOPIC SUBSTITUTION IS ALLOWED.
*
***********************************************************************
      COMMON /EULER / TVEC(3,3), ID
      COMMON /SCRACH/ STORE(MAXPAR**2)
      DIMENSION XPARAM(MAXPAR), GR(3,NUMATM),
     1DELDIP(3,MAXPAR), TRDIP(3,MAXPAR)
     2,REDMAS(MAXPAR), SHIFT(6)
     3, ROT(3,3)
      CHARACTER KEYWRD*80, KEYS(80)*1
      LOGICAL RESTRT, DIPOK, LINEAR, DEBUG, BARTEL
      EQUIVALENCE (GRAD(1), GR(1,1)), (KEYWRD,KEYS(1))
C
C TEST GEOMETRY TO SEE IF IT IS OPTIMISED
      TIME2=-1.D9
      CALL GMETRY(GEO,COORD)
      NVAR=0
      NUMAT=0
      IF(LABELS(1) .NE. 99) NUMAT=1
      DO 20 I=2,NATOMS
         IF(LABELS(I).EQ.99.OR.LABELS(I).EQ.107) GOTO 20
         NUMAT=NUMAT+1
         IF(I.EQ.2)ILIM=1
         IF(I.EQ.3)ILIM=2
         IF(I.GT.3)ILIM=3
         DO 10 J=1,ILIM
            NVAR=NVAR+1
            LOC(1,NVAR)=I
            LOC(2,NVAR)=J
   10    XPARAM(NVAR)=GEO(J,I)
   20 CONTINUE
C
C   IF A RESTART, THEN TSCF AND TDER WILL BE FAULTY, THEREFORE SET TO -1
C
      TSCF=-1.D0
      TDER=-1.D0
      DEBUG=(INDEX(KEYWRD,'DFORCE') .NE. 0)
      BARTEL=(INDEX(KEYWRD,'NLLSQ') .NE. 0)
      RESTRT=(INDEX(KEYWRD,'RESTART') .NE. 0)
      TIME1=SECOND()
      IF (RESTRT) THEN
C
C   CHECK TO SEE IF CALCULATION IS IN NLLSQ OR FORCE.
C
         IF(BARTEL)GOTO 40
C
C   CALCULATION IS IN FORCE
C
         GOTO 70
      ENDIF
      CALL COMPFG( XPARAM, .TRUE., ESCF, .TRUE., GRAD, .FALSE.)
      WRITE(6,'(//10X,''HEAT OF FORMATION ='',F12.6,
     1'' KCALS/MOLE'')')ESCF
      TIME2=SECOND()
      TSCF=TIME2-TIME1
      CALL COMPFG( XPARAM, .TRUE., ESCF, .FALSE., GRAD, .TRUE.)
      TIME3=SECOND()
      TDER=TIME3-TIME2
      WRITE(6,'(//10X,''INTERNAL COORDINATE DERIVATIVES'',//3X,
     1''ATOM  AT. NO.'',2X,''BOND'',9X,''ANGLE'',8X,''DIHEDRAL'',/)')
      L=0
      IU=0
      DO 30 I=1,NATOMS
         IF(LABELS(I).EQ.99) GOTO 30
         L=L+1
         IL=IU+1
         IF(I .EQ. 1) IU=IL-1
         IF(I .EQ. 2) IU=IL
         IF(I .EQ. 3) IU=IL+1
         IF(I .GT. 3) IU=IL+2
         WRITE(6,'(2I6,F13.6,2F10.6)') L,LABELS(I),(GRAD(J),J=IL,IU)
   30 CONTINUE
C   TEST SUM OF GRADIENTS
      GNORM=SQRT(DOT(GRAD,GRAD,NVAR))
      WRITE(6,'(//10X,''GRADIENT NORM ='',F10.5)') GNORM
      IF(GNORM.LT.10.D0) GOTO 50
      WRITE(6,'(///1X,''** GRADIENT IS TOO LARGE TO ALLOW '',
     1    ''FORCE MATRIX TO BE CALCULATED, (LIMIT=10) **'',//)')
      IF(INDEX(KEYWRD,' LET ') .NE. 0) GOTO 60
   40 CONTINUE
      WRITE(6,'(//10X,'' GEOMETRY WILL BE OPTIMISED FIRST'')')
      IF(BARTEL) THEN
         WRITE(6,'(15X,''USING NLLSQ'')')
         CALL NLLSQ(XPARAM,NVAR)
      ELSE
         WRITE(6,'(15X,''USING FLEPO'')')
         CALL FLEPO(XPARAM,NVAR,ESCF)
      ENDIF
      CALL COMPFG( XPARAM, .TRUE., ESCF, .TRUE., GRAD, .TRUE.)
      CALL WRITE(TIME1,ESCF)
      WRITE(6,'(//10X,''GRADIENT NORM ='',F10.7)') GNORM
      CALL GMETRY(GEO,COORD)
   50 CONTINUE
C
C NOW TO CALCULATE THE FORCE MATRIX
C
C CHECK OUT SYMMETRY
   60 CONTINUE
      IF(INDEX(KEYWRD,'THERMO').NE.0 .AND.GNORM.GT.1.D0) THEN
         WRITE(6,'(//30X,''**** WARNING ****'',//
     110X,'' GRADIENT IS VERY LARGE FOR A THERMO CALCULATION'',/
     210X,'' RESULTS ARE LIKELY TO BE INACCURATE IF THERE ARE'')')
         WRITE(6,'(10X,'' ANY LOW-LYING VIBRATIONS (LESS THAN ABOUT ''
     1,''400CM-1)'',/
     210X,'' GRADIENT NORM SHOULD BE LESS THAN ABOUT 0.2 FOR THERMO'',//
     310X,'' TO GIVE ACCURATE RESULTS'')')
      ENDIF
      IF(TSCF.GT.0.D0) THEN
         WRITE(6,'(//10X,''TIME FOR SCF CALCULATION ='',F8.2)')TSCF
         WRITE(6,'(//10X,''TIME FOR DERIVATIVES     ='',F8.2)')TDER
      ENDIF
   70 CONTINUE
      IF(NDEP.GT.0) THEN
         WRITE(6,'(//10X,''SYMMETRY WAS SPECIFIED, BUT '',
     1''CANNOT BE USED HERE'')')
         NDEP=0
      ENDIF
      CALL AXIS(COORD,NUMAT,A,B,C,WTMOL,2,ROT)
      WRITE(6,'(/9X,''ORIENTATION OF MOLECULE IN FORCE CALCULATION'')')
      WRITE(6,'(/,4X,''NO.'',7X,''ATOM'',9X,''X'',
     19X,''Y'',9X,''Z'',/)')
      L=0
      DO 80 I=1,NATOMS
         IF(LABELS(I) .EQ. 99) GOTO 80
         L=L+1
         WRITE(6,'(I6,7X,I3,4X,3F10.4)')
     1    L,LABELS(I),(COORD(J,L),J=1,3)
   80 CONTINUE
      CALL FMAT(FMATRX, TSCF, TDER, DELDIP,ESCF)
C
C   THE FORCE MATRIX IS PRINTED AS AN ATOM-ATOM MATRIX RATHER THAN
C   AS A 3N*3N MATRIX, AS THE 3N MATRIX IS VERY CONFUSING!
C
      IJ=0
      IU=0
      DO 110 I=1,NUMAT
         IL=IU+1
         IU=IL+2
         IM1=I-1
         JU=0
         DO 100 J=1,IM1
            JL=JU+1
            JU=JL+2
            SUM=0.D0
            DO 90 II=IL,IU
               DO 90 JJ=JL,JU
   90       SUM=SUM+FMATRX((II*(II-1))/2+JJ)**2
            IJ=IJ+1
  100    STORE(IJ)=SQRT(SUM)
         IJ=IJ+1
  110 STORE(IJ)=SQRT(
     1FMATRX(((IL+0)*(IL+1))/2)**2+
     2FMATRX(((IL+1)*(IL+2))/2)**2+
     3FMATRX(((IL+2)*(IL+3))/2)**2+2.D0*(
     4FMATRX(((IL+1)*(IL+2))/2-1)**2+
     5FMATRX(((IL+2)*(IL+3))/2-2)**2+
     6FMATRX(((IL+2)*(IL+3))/2-1)**2))
      IF(DEBUG) THEN
         WRITE(6,'(//10X,'' FULL FORCE MATRIX, INVOKED BY "DFORCE"'')')
         I=-NVAR
         CALL VECPRT(FMATRX,I)
      ENDIF
      WRITE(6,'(//10X,'' FORCE MATRIX IN MILLIDYNES/ANGSTROM'')')
      CALL VECPRT(STORE,NUMAT)
      L=(NVAR*(NVAR+1))/2
      DO 120 I=1,L
  120 STORE(I)=FMATRX(I)
      CALL AXIS(COORD,NUMAT,A,B,C,SUM,0,ROT)
      CALL FRAME(STORE,NUMAT,0, SHIFT)
      CALL HQRII(STORE,NVAR,NVAR,FREQ,CNORML)
      WRITE(6,'(//10X,''HEAT OF FORMATION ='',F12.6,
     1'' KCALS/MOLE'')')ESCF
      NVIB=NVAR-6
      IF(ABS(C).LT.1.D-20)NVIB=NVIB+1
      IF(ID.NE.0)NVIB=NVAR-3
      DO 130 I=NVIB+1,NVAR
         J=(FREQ(I)+50.D0)*0.01D0
  130 FREQ(I)=FREQ(I)-J*100
      WRITE(6,'(//10X,''TRIVIAL VIBRATIONS, SHOULD BE ZERO'')')
      WRITE(6,'(/, F9.4,''=TX'',F9.4,''=TY'',F9.4,''=TZ'',
     1             F9.4,''=RX'',F9.4,''=RY'',F9.4,''=RZ'')')
     2(FREQ(I),I=NVIB+1,NVAR)
      WRITE(6,'(//10X,''FORCE CONSTANTS IN MILLIDYNES/ANGSTROM''
     1,'' (= 10**5 DYNES/CM)'',/)')
      WRITE(6,'(8F10.5)')(FREQ(I),I=1,NVIB)
C CONVERT TO WEIGHTED FMAT
      WRITE(6,'(//10X,'' ASSOCIATED EIGENVECTORS'')')
      I=-NVAR
      CALL MATOUT(CNORML,FREQ,NVIB,I,NVAR)
      CALL FREQCY(FMATRX,FREQ,CNORML,REDMAS)
C
C  CALCULATE ZERO POINT ENERGY
C
C
C  THESE CONSTANTS TAKEN FROM HANDBOOK OF CHEMISTRY AND PHYSICS 62ND ED.
C   N AVOGADRO'S NUMBER = 6.022045*10**23
C   H PLANCK'S CONSTANT = 6.626176*10**(-34)JHZ
C   C SPEED OF LIGHT    = 2.99792458*10**10 CM/SEC
C   CONST=0.5*N*H*C/(1000*4.184)
      CONST=1.4295718D-3
      SUM=0.D0
      DO 140 I=1,NVAR
  140 SUM=SUM+FREQ(I)
      SUM=SUM*CONST
      WRITE(6,'(//10X,'' ZERO POINT ENERGY''
     1, F12.3,'' KILOCALORIES PER MOLE'')')SUM
      SUMM=0.D0
      DO 180 I=1,NVAR
         DO 150 K=1,3
  150    GRAD(K)=0.D0
         DO 170 K=1,3
            SUM=0.D0
            DO 160 J=1,NVAR
  160       SUM=SUM+CNORML(J+(I-1)*NVAR)*DELDIP(K,J)
            SUMM=SUMM+ABS(SUM)
  170    TRDIP(K,I)=SUM
  180 CONTINUE
      DIPOK  =  (SUMM.GT.0.1D0)
      WRITE(6,'(//3X,'' THE LAST'',I2,'' VIBRATIONS ARE THE'',
     1'' TRANSLATION AND ROTATION MODES'')')NVAR-NVIB
      WRITE(6,'(3X,'' THE FIRST THREE OF THESE BEING TRANSLATIONS'',
     1'' IN X, Y, AND Z, RESPECTIVELY'')')
      IF(DIPOK) THEN
         WRITE(6,'(//10X,'' FREQUENCIES, REDUCED MASSES AND '',
     1''VIBRATIONAL DIPOLES''/)')
      ELSE
         WRITE(6,'(//10X,''      FREQUENCIES AND REDUCED MASSES ''/)')
      ENDIF
      NTO6=NVAR/6
      NREM6=NVAR-NTO6*6
      IINC1=-5
      IF (NTO6.LT.1) GO TO 200
      DO 190 I=1,NTO6
         WRITE (6,'(/)')
         IINC1=IINC1+6
         IINC2=IINC1+5
         WRITE (6,'(3X,''I'',10I10)') (J,J=IINC1,IINC2)
         WRITE (6,'('' FREQ(I)'',6F10.4,/)') (FREQ(J),J=IINC1,IINC2)
         WRITE (6,'('' MASS(I)'',6F10.5,/)') (REDMAS(J),J=IINC1,IINC2)
         IF(DIPOK) THEN
            WRITE (6,'('' DIPX(I)'',6F10.5)') (TRDIP(1,J),J=IINC1,IINC2)
            WRITE (6,'('' DIPY(I)'',6F10.5)') (TRDIP(2,J),J=IINC1,IINC2)
            WRITE (6,'('' DIPZ(I)'',6F10.5,/)') (TRDIP(3,J),J=IINC1,IINC
     12)
            WRITE (6,'('' DIPT(I)'',6F10.5)')
     1   (SQRT(TRDIP(1,J)**2+TRDIP(2,J)**2+TRDIP(3,J)**2)
     2   ,J=IINC1,IINC2)
         ENDIF
  190 CONTINUE
  200 CONTINUE
      IF (NREM6.LT.1) GO TO 210
      WRITE (6,'(/)')
      IINC1=IINC1+6
      IINC2=IINC1+(NREM6-1)
      WRITE (6,'(3X,''I'',10I10)') (J,J=IINC1,IINC2)
      WRITE (6,'('' FREQ(I)'',6F10.4)') (FREQ(J),J=IINC1,IINC2)
      WRITE (6,'(/,'' MASS(I)'',6F10.5)') (REDMAS(J),J=IINC1,IINC2)
      IF(DIPOK) THEN
         WRITE (6,'(/,'' DIPX(I)'',6F10.5)') (TRDIP(1,J),J=IINC1,IINC2)
         WRITE (6,'('' DIPY(I)'',6F10.5)') (TRDIP(2,J),J=IINC1,IINC2)
         WRITE (6,'('' DIPZ(I)'',6F10.5)') (TRDIP(3,J),J=IINC1,IINC2)
         WRITE (6,'(/,'' DIPT(I)'',6F10.5)')
     1   (SQRT(TRDIP(1,J)**2+TRDIP(2,J)**2+TRDIP(3,J)**2)
     2   ,J=IINC1,IINC2)
      ENDIF
  210 CONTINUE
      WRITE(6,'(//10X,'' NORMAL VECTORS'')')
      I=-NVAR
      CALL MATOUT(CNORML,FREQ,NVAR,I,NVAR)
      CALL ANAVIB(COORD,FREQ,NVAR,CNORML,FMATRX)
      IF(INDEX(KEYWRD,'THERMO').NE.0) THEN
         CALL GMETRY(GEO,COORD)
         I=INDEX(KEYWRD,' ROT')
         IF(I.NE.0) THEN
            SYM=READA(KEYWRD,I)
         ELSE
            SYM=1
         ENDIF
         LINEAR=(ABS(A*B*C) .LT. 1.D-10)
         I=INDEX(KEYWRD,' TRANS')
C
C   "I" IS GOING TO MARK THE BEGINNING OF THE GENUINE VIBRATIONS.
C
         IF(I.NE.0)THEN
            WRITE(6,'(//10X,''SYSTEM IS A TRANSITION STATE'')')
            I=2
            J=NVIB-1
         ELSE
            WRITE(6,'(//10X,''SYSTEM IS A GROUND STATE'')')
            I=1
            J=NVIB
         ENDIF
         CALL THERMO(A,B,C,LINEAR,SYM,WTMOL,FREQ(I),J)
      ENDIF
      RETURN
      END


99 9[1-$][\$@$@$@$@\/*=[1-$$[%\1-$@]?0=[\$.' ,\]?]?]#%%"
"


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine setnonb: Set various arrays for QMDFF non-bonding potential, not
!                molecule specific
!
!     part of QMDFF
!
subroutine setnonb(scalehb,scalexb,vz,sr42,zab,r0ab)
use qmdff
use general
implicit none
real(kind=8)::vz(94),zab(94,94),r0ab(94,94)
real(kind=8)::sr42(94,94),scalehb(94),scalexb(94)

integer::i,j
!
!     D3 (Becke-Johnson damping) parameters
!     eq. (11) in QMDFF paper
!
a1 = 0.45
s8 = 2.7
a2 = 4.0
!
!     unknown parameters for damping function (?)
!

r2r4 = (/ &
 & 2.00734898,  1.56637132,  5.01986934,  3.85379032,  3.64446594, &
 & 3.10492822,  2.71175247,  2.59361680,  2.38825250,  2.21522516, &
 & 6.58585536,  5.46295967,  5.65216669,  4.88284902,  4.29727576, &
 & 4.04108902,  3.72932356,  3.44677275,  7.97762753,  7.07623947, &
 & 6.60844053,  6.28791364,  6.07728703,  5.54643096,  5.80491167, &
 & 5.58415602,  5.41374528,  5.28497229,  5.22592821,  5.09817141, &
 & 6.12149689,  5.54083734,  5.06696878,  4.87005108,  4.59089647, &
 & 4.31176304,  9.55461698,  8.67396077,  7.97210197,  7.43439917, &
 & 6.58711862,  6.19536215,  6.01517290,  5.81623410,  5.65710424, &
 & 5.52640661,  5.44263305,  5.58285373,  7.02081898,  6.46815523, &
 & 5.98089120,  5.81686657,  5.53321815,  5.25477007, 11.02204549, &
 &10.15679528,  9.35167836,  9.06926079,  8.97241155,  8.90092807, &
 & 8.85984840,  8.81736827,  8.79317710,  7.89969626,  8.80588454, &
 & 8.42439218,  8.54289262,  8.47583370,  8.45090888,  8.47339339, &
 & 7.83525634,  8.20702843,  7.70559063,  7.32755997,  7.03887381, &
 & 6.68978720,  6.05450052,  5.88752022,  5.70661499,  5.78450695, &
 & 7.79780729,  7.26443867,  6.78151984,  6.67883169,  6.39024318, &
 & 6.09527958, 11.79156076, 11.10997644,  9.51377795,  8.67197068, &
 & 8.77140725,  8.65402716,  8.53923501,  8.85024712 /)
!
!     R0AB parameters in damping function
!
rcov = (/ &
 & 0.80628308, 1.15903197, 3.02356173, 2.36845659, 1.94011865, &
 & 1.88972601, 1.78894056, 1.58736983, 1.61256616, 1.68815527, &
 & 3.52748848, 3.14954334, 2.84718717, 2.62041997, 2.77159820, &
 & 2.57002732, 2.49443835, 2.41884923, 4.43455700, 3.88023730, &
 & 3.35111422, 3.07395437, 3.04875805, 2.77159820, 2.69600923, &
 & 2.62041997, 2.51963467, 2.49443835, 2.54483100, 2.74640188, &
 & 2.82199085, 2.74640188, 2.89757982, 2.77159820, 2.87238349, &
 & 2.94797246, 4.76210950, 4.20778980, 3.70386304, 3.50229216, &
 & 3.32591790, 3.12434702, 2.89757982, 2.84718717, 2.84718717, &
 & 2.72120556, 2.89757982, 3.09915070, 3.22513231, 3.17473967, &
 & 3.17473967, 3.09915070, 3.32591790, 3.30072128, 5.26603625, &
 & 4.43455700, 4.08180818, 3.70386304, 3.98102289, 3.95582657, &
 & 3.93062995, 3.90543362, 3.80464833, 3.82984466, 3.80464833, &
 & 3.77945201, 3.75425569, 3.75425569, 3.72905937, 3.85504098, &
 & 3.67866672, 3.45189952, 3.30072128, 3.09915070, 2.97316878, &
 & 2.92277614, 2.79679452, 2.82199085, 2.84718717, 3.32591790, &
 & 3.27552496, 3.27552496, 3.42670319, 3.30072128, 3.47709584, &
 & 3.57788113, 5.06446567, 4.56053862, 4.20778980, 3.98102289, &
 & 3.82984466, 3.85504098, 3.88023730, 3.90543362 /)

!
!     COVALENT RADII of all elements
!     based on "Atomic Radii of the Elements," M. Mantina, R. Valero, C. J. Cramer, and D. G. Truhlar,
!     in CRC Handbook of Chemistry and Physics, 91st Edition (2010-2011),
!     edited by W. M. Haynes (CRC Press, Boca Raton, FL, 2010), pages 9-49-9-50;
!     corrected Nov. 17, 2010 for the 92nd edition.
!
rad = (/ &
 & 0.32D0,0.37D0,1.30D0,0.99D0,0.84D0,0.75D0,0.71D0,0.64D0,0.60D0, &
 & 0.62D0,1.60D0,1.40D0,1.24D0,1.14D0,1.09D0,1.04D0,1.00D0,1.01D0, &
 & 2.00D0,1.74D0,1.59D0,1.48D0,1.44D0,1.30D0,1.29D0,1.24D0,1.18D0, &
 & 1.17D0,1.22D0,1.20D0,1.23D0,1.20D0,1.20D0,1.18D0,1.17D0,1.16D0, &
 & 2.15D0,1.90D0,1.76D0,1.64D0,1.56D0,1.46D0,1.38D0,1.36D0,1.34D0, &
 & 1.30D0,1.36D0,1.40D0,1.42D0,1.40D0,1.40D0,1.37D0,1.36D0,1.36D0, &
 & 2.38D0,2.06D0,1.94D0,1.84D0,1.90D0,1.88D0,1.86D0,1.85D0,1.83D0, &
 & 1.82D0,1.81D0,1.80D0,1.79D0,1.77D0,1.77D0,1.78D0,1.74D0,1.64D0, &
 & 1.58D0,1.50D0,1.41D0,1.36D0,1.32D0,1.30D0,1.30D0,1.32D0,1.44D0, &
 & 1.45D0,1.50D0,1.42D0,1.48D0,1.46D0,2.42D0,2.11D0,2.01D0,1.90D0, &
 & 1.84D0,1.83D0,1.80D0,1.80D0 /)
rad=rad/bohr
!
!     as in qmsolv (D3 is in block.f):
!     scaling parameters for hydrogen bonds (HB)
!     only for H,O,N,... unequal zero
!
scalehb=0
scalehb(7  )=0.8
scalehb(8  )=0.3
scalehb(9  )=0.1
scalehb(15 )=2.0
scalehb(16 )=2.0
scalehb(17 )=2.0
scalehb(34 )=2.0
scalehb(35 )=2.0
!
!     scaling parameters for halogen bonds (XB)
!
scalexb=0
scalexb(17 )=0.30
scalexb(35 )=0.60
scalexb(53 )=0.80
scalexb(85 )=1.00
!
!     valence charges (REP), 4 fit parameters included there
!
call valel(vz)
!
!     determine D3 parameters
!
do i=1,94
   do j=1,94
      sr42(j,i)=3.0d0*s8*r2r4(i)*r2r4(j)
      r094(j,i)=a1*sqrt(3.0d0*r2r4(i)*r2r4(j))+a2
      zab (j,i)=vz(i)*vz(j)
   end do
end do
!
!     get D3 radii (used in REP), alpha included for calc. of REP energy
!     Pauli repulsion formula (eq. (12))
!
call setr0(94,r0ab)
r0ab = 16.5 / r0ab**1.5
!
!     intramolecular damping parameters (Becke-Johnson)
!     fitted to aconf,pconf,cyconf,sconf,mconf
!
eps1(1)=0
eps1(2)=0
eps1(3)=0.85
eps1(4)=1
eps1(5)=1

!
!     rot34 geometries very sensitive to scaling
!
eps2(1)=0
eps2(2)=0
eps2(3)=0.5
eps2(4)=0.5
eps2(5)=1

!
!     repulsion-dispersion for 1,3-metal.
!
eps2(6)=1.00
eps1(6)=0
!
!     overlap scaling
!
eps3(1:3)=1
eps3(4)=0.5
eps3(5)=0
eps3(6)=0

end subroutine setnonb