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, 2.4RT           #
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 #              VLIDORT_UPUSER_INTENSITY                       #
C #              VLIDORT_DNUSER_INTENSITY                       #
C #                                                             #
C #              GET_TOASOURCE                                  #
C #              BOA_LAMBERTIAN_SOURCE                          #
C #                                                             #
C #              WHOLELAYER_STERM_UP                            #
C #              WHOLELAYER_STERM_DN                            #
C #              PARTLAYER_STERM_UP                             #
C #              PARTLAYER_STERM_DN                             #
C #                                                             #
C ###############################################################

      SUBROUTINE VLIDORT_UPUSER_INTENSITY
     I    ( DO_INCLUDE_SURFACE,
     I      DO_INCLUDE_SURFEMISS,
     I      DO_INCLUDE_THERMEMISS,
     I      DO_INCLUDE_DIRECTBEAM,
     I      DO_INCLUDE_MVOUTPUT,
     I      FOURIER_COMPONENT,  IBEAM,
     I      SURFACE_FACTOR,
     I      GET_BOA_SOURCE,
     I      FLUX_MULTIPLIER )

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 and solution variables (input)

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

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

      INCLUDE '../includes/VLIDORT_RESULTS.VARS'

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

C  Fourier component, beam index

      INTEGER          FOURIER_COMPONENT
      INTEGER          IBEAM

C  External function

      EXTERNAL         GET_BOA_SOURCE

C  multipliers

      DOUBLE PRECISION FLUX_MULTIPLIER
      DOUBLE PRECISION SURFACE_FACTOR

C  Local include flags

      LOGICAL          DO_INCLUDE_SURFACE
      LOGICAL          DO_INCLUDE_DIRECTBEAM
      LOGICAL          DO_INCLUDE_SURFEMISS
      LOGICAL          DO_INCLUDE_THERMEMISS
      LOGICAL          DO_INCLUDE_MVOUTPUT

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

      LOGICAL          SFLAG
      INTEGER          N, NUT, NSTART, NUT_PREV, NLEVEL, NC, O1
      INTEGER          UT, UTA, UM
      DOUBLE PRECISION LAYER_SOURCE(MAX_USER_STREAMS,MAXSTOKES)
      DOUBLE PRECISION FINAL_SOURCE

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 UM = 1, N_USER_STREAMS
            DO O1 = 1, NSTOKES
              STOKES_F(UTA,UM,IBEAM,O1,UPIDX) = ZERO
            ENDDO
          ENDDO
        ENDDO
      ENDIF

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

      IF ( DO_USER_STREAMS ) THEN

C  Get the BOA source terms (diffuse + direct)
C    External Call, introduced 27 March 2007.

        CALL GET_BOA_SOURCE
     I    ( DO_INCLUDE_SURFACE,
     I      DO_INCLUDE_SURFEMISS,
     I      DO_INCLUDE_DIRECTBEAM,
     I      DO_INCLUDE_MVOUTPUT,
     I      FOURIER_COMPONENT, IBEAM,
     I      SURFACE_FACTOR )

C  Set the cumulative source term equal to BOA values

        NC = 0
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            CUMSOURCE_UP(UM,O1,NC) = BOA_DIFFUSE_SOURCE(UM,O1) +
     &                               BOA_DIRECT_SOURCE(UM,O1)
!          write(*,*)um,BOA_DIFFUSE_SOURCE(UM,O1),
!     &                               BOA_DIRECT_SOURCE(UM,O1)
          ENDDO
        ENDDO
!        pause

C  Debug write

c        IF ( DO_DEBUG_WRITE ) THEN
c          DO UM = LOCAL_UM_START, N_USER_STREAMS
c           DO O1 = 1, NSTOKES
c            if ( um.eq.1.and.o1.eq.1) then
c              IF ( FOURIER_COMPONENT.EQ.0.AND.DO_FDTEST)THEN
c                write(81,*) UM,O1,BOA_DIFFUSE_SOURCE(UM,O1),
C     &                            BOA_DIRECT_SOURCE(UM,O1)
c              ELSE IF ( FOURIER_COMPONENT.EQ.0.AND..NOT.DO_FDTEST)THEN
c                write(82,*) UM,O1,BOA_DIFFUSE_SOURCE(UM,O1),
C     &                            BOA_DIRECT_SOURCE(UM,O1)
c              ENDIF
c            endif
c           ENDDO
c          ENDDO
c        ENDIF

      ENDIF

C  Recursion Loop in Source function integration
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 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 WHOLELAYER_STERM_UP
     &        ( N, FOURIER_COMPONENT, IBEAM,
     &          SFLAG, DO_INCLUDE_THERMEMISS, LAYER_SOURCE )
            DO UM = LOCAL_UM_START, N_USER_STREAMS
              DO O1 = 1, NSTOKES
                CUMSOURCE_UP(UM,O1,NC) = LAYER_SOURCE(UM,O1) +
     &                   T_DELT_USERM(N,UM)*CUMSOURCE_UP(UM,O1,NC-1)
              ENDDO
            ENDDO
          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 PARTLAYER_STERM_UP
     &         ( N, UT, IBEAM, SFLAG,
     &           DO_INCLUDE_THERMEMISS, LAYER_SOURCE )
            DO UM = LOCAL_UM_START, N_USER_STREAMS
              DO O1 = 1, NSTOKES
                FINAL_SOURCE = LAYER_SOURCE(UM,O1) +
     &                       T_UTUP_USERM(UT,UM)*CUMSOURCE_UP(UM,O1,NC)
                STOKES_F(UTA,UM,IBEAM,O1,UPIDX) =
     &                       FLUX_MULTIPLIER * FINAL_SOURCE
              ENDDO
            ENDDO
          ENDIF

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

        ELSE

C  User-defined stream output, just set to the cumulative source term
C   Commented out code helps with FD testing

          IF ( DO_USER_STREAMS ) THEN
            DO UM = LOCAL_UM_START, N_USER_STREAMS
              DO O1 = 1, NSTOKES
                FINAL_SOURCE = FLUX_MULTIPLIER * CUMSOURCE_UP(UM,O1,NC)
                STOKES_F(UTA,UM,IBEAM,O1,UPIDX) = FINAL_SOURCE
!                if (DABS(FINAL_SOURCE).GT.1.0d-10 ) then           ! FDHELP
!                  STOKES_F(UTA,UM,IBEAM,O1,UPIDX) = FINAL_SOURCE   ! FDHELP
!                endif                                              ! FDHELP
              ENDDO
            ENDDO
          ENDIF

        ENDIF

C  debug write

c        IF ( DO_DEBUG_WRITE ) THEN
c         DO UM = LOCAL_UM_START, N_USER_STREAMS
c          DO O1 = 1, NSTOKES
c            if (do_fdtest) then
c                write(69,'(5i3,1pe20.10)')
c     &         fourier_component,uta,ibeam,um,o1,
c     &           STOKES_F(UTA,UM,IBEAM,O1,UPIDX)
c            endif
c          ENDDO
c         ENDDO
c        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      if ( fourier_component.eq.6) pause 'user intensity'

C  Finish

      RETURN
      END

C

      SUBROUTINE VLIDORT_DNUSER_INTENSITY
     I    ( DO_INCLUDE_THERMEMISS,
     I      FLUX_MULTIPLIER,
     I      FOURIER_COMPONENT, IBEAM )

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 and solution variables (input)

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

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

      INCLUDE '../includes/VLIDORT_RESULTS.VARS'

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

C  Thermal emissioin control

      LOGICAL          DO_INCLUDE_THERMEMISS

C  multipliers

      DOUBLE PRECISION FLUX_MULTIPLIER

C  Fourier component

      INTEGER          FOURIER_COMPONENT

C  beam index

      INTEGER          IBEAM

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

      LOGICAL          SFLAG
      INTEGER          N, NUT, NSTART, NUT_PREV, NLEVEL
      INTEGER          UT, UTA, UM, NC, O1
      DOUBLE PRECISION TOA_SOURCE(MAX_USER_STREAMS,MAXSTOKES)
      DOUBLE PRECISION LAYER_SOURCE(MAX_USER_STREAMS,MAXSTOKES)
      DOUBLE PRECISION FINAL_SOURCE

C  Zero all Fourier components close to zenith

      IF ( DO_USER_STREAMS ) THEN
        IF ( LOCAL_UM_START .GT. 1 ) THEN
          DO UTA = 1, N_USER_LEVELS
            DO UM = 1, LOCAL_UM_START - 1
              DO O1 = 1, NSTOKES
                STOKES_F(UTA,UM,IBEAM,O1,DNIDX) = ZERO
              ENDDO
            ENDDO
          ENDDO
        ENDIF
      ENDIF

C  Initialize recursion for user-defined stream angles only

      IF ( DO_USER_STREAMS ) THEN
        CALL GET_TOASOURCE ( TOA_SOURCE )
        NC = 0
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            CUMSOURCE_DN(UM,O1,NC) = TOA_SOURCE(UM,O1)
          ENDDO
        ENDDO
      ENDIF

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 WHOLELAYER_STERM_DN
     &        ( N, IBEAM, SFLAG, DO_INCLUDE_THERMEMISS, LAYER_SOURCE )
            DO UM = LOCAL_UM_START, N_USER_STREAMS
              DO O1 = 1, NSTOKES
                CUMSOURCE_DN(UM,O1,NC) = LAYER_SOURCE(UM,O1) +
     &                    T_DELT_USERM(N,UM)*CUMSOURCE_DN(UM,O1,NC-1)
              ENDDO
            ENDDO
          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 PARTLAYER_STERM_DN
     &    ( N, UT, IBEAM, SFLAG, DO_INCLUDE_THERMEMISS, LAYER_SOURCE )
            DO UM = LOCAL_UM_START, N_USER_STREAMS
              DO O1 = 1, NSTOKES
                FINAL_SOURCE = LAYER_SOURCE(UM,O1) +
     &                       T_UTDN_USERM(UT,UM)*CUMSOURCE_DN(UM,O1,NC)
                STOKES_F(UTA,UM,IBEAM,O1,DNIDX) =
     &                       FLUX_MULTIPLIER * FINAL_SOURCE
              ENDDO
            ENDDO
          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
                STOKES_F(UTA,UM,IBEAM,O1,DNIDX) =
     &                 FLUX_MULTIPLIER * CUMSOURCE_DN(UM,O1,NC)
              ENDDO
            ENDDO
          ENDIF

        ENDIF

c        IF ( DO_DEBUG_WRITE ) THEN
c         DO UM = LOCAL_UM_START, N_USER_STREAMS
c          DO O1 = 1, NSTOKES
c            if (do_fdtest) then
c                if (uta.gt.1)write(69,'(5i3,1pe20.10)')
c     &         fourier_component,uta-1,ibeam,um,o1,
c     &           STOKES_F(UTA,UM,IBEAM,O1,DNIDX)
c            endif
c          ENDDO
c         ENDDO
c        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_TOASOURCE ( TOA_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  Subroutine arguments

      DOUBLE PRECISION TOA_SOURCE(MAX_USER_STREAMS,MAXSTOKES)

C  local variables

      INTEGER          UM, O1

C  initialise TOA source function

      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          TOA_SOURCE(UM,O1) = ZERO
        ENDDO
      ENDDO

C  Finish

      RETURN
      END

C

      SUBROUTINE BOA_LAMBERTIAN_SOURCE
     I    ( DO_INCLUDE_SURFACE,
     I      DO_INCLUDE_SURFEMISS,
     I      DO_INCLUDE_DIRECTBEAM,
     I      DO_INCLUDE_MVOUTPUT,
     I      FOURIER_COMPONENT, IBEAM,
     I      SURFACE_FACTOR )

C  Bottom of the atmosphere source term, Lambertian

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 solution, setup & reflectance variables (input, output)

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

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

C  local control flags

      LOGICAL          DO_INCLUDE_SURFACE
      LOGICAL          DO_INCLUDE_DIRECTBEAM
      LOGICAL          DO_INCLUDE_SURFEMISS
      LOGICAL          DO_INCLUDE_MVOUTPUT

C  surface multiplier and Fourier index

      DOUBLE PRECISION SURFACE_FACTOR
      INTEGER          FOURIER_COMPONENT
      INTEGER          IBEAM

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

      INTEGER          N, J, I, IR, IROW, UM, O1, O11
      INTEGER          K, KO1, K0, K1, K2
      DOUBLE PRECISION REFLEC, STOTAL, KMULT, LOCAL_EMISS, FP_SBB
      DOUBLE PRECISION SPAR, HOM1, HOM2, SHOM_R
      DOUBLE PRECISION SHOM_CR, HOM1CR, HOM2CR
      DOUBLE PRECISION LXR, MXR, LXR_CR, LXR_CI, MXR_CR

      LOGICAL          DO_QTHTONLY
      DOUBLE PRECISION THELP(MAXSTREAMS)

C  initialise boa source function

      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          BOA_DIFFUSE_SOURCE(UM,O1) = ZERO
          BOA_DIRECT_SOURCE(UM,O1)  = ZERO
        ENDDO
      ENDDO

C  Special flag

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

C  Layer index and offset

      N = NLAYERS
      KO1 = K_REAL(N) + 1

C  1-1 element index

      O11 = 1

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

      IF ( DO_INCLUDE_SURFACE ) THEN

C  Thermal transmittance solution, build from TOA downwards

        IF ( DO_THERMAL_TRANSONLY ) THEN
          DO I = 1, NSTREAMS
            THELP(I) = ZERO
          ENDDO
          DO K = 1, NLAYERS
            DO I = 1, NSTREAMS
              THELP(I) = THELP(I)*T_DELT_DISORDS(I,K) + T_WLOWER(I,K)
            ENDDO
          ENDDO
          DO I = 1, NSTREAMS
            STOKES_DOWNSURF(I,O11) = QUAD_WEIGHTS(I) * THELP(I)
          ENDDO
        ENDIF

C  Full solution: Downward intensity at computational angles (beam/homog)
C     --> Develop reflectance integrand  a(j).x(j).I(-j)

        IF ( .NOT. DO_THERMAL_TRANSONLY ) THEN

C  Downward Stokes vector at surface at computational angles
C    reflectance integrand  a(j).x(j).I(-j)

         DO I = 1, NSTREAMS
           IR = ( I - 1 ) * NSTOKES
           DO O1 = 1, NSTOKES
             IROW = IR + O1
             SPAR = WLOWER(I,O1,N)
             SHOM_R = ZERO
             DO K = 1, K_REAL(N)
               LXR  = LCON(K,N)*SOLA_XPOS(I,O1,K,N)
               MXR  = MCON(K,N)*SOLB_XNEG(I,O1,K,N)
               HOM1 = LXR * T_DELT_EIGEN(K,N)
               HOM2 = MXR
               SHOM_R = SHOM_R + HOM1 + HOM2
             ENDDO
             SHOM_CR = ZERO
             DO K = 1, K_COMPLEX(N)
               K0 = 2*K-2
               K1 = KO1 + K0
               K2 = K1  + 1
               LXR_CR =  LCON(K1,N) * SOLA_XPOS(I,O1,K1,N) -
     &                   LCON(K2,N) * SOLA_XPOS(I,O1,K2,N)
               LXR_CI =  LCON(K1,N) * SOLA_XPOS(I,O1,K2,N) +
     &                   LCON(K2,N) * SOLA_XPOS(I,O1,K1,N)
               MXR_CR =  MCON(K1,N) * SOLB_XNEG(I,O1,K1,N) -
     &                   MCON(K2,N) * SOLB_XNEG(I,O1,K2,N)
               HOM1CR = LXR_CR*T_DELT_EIGEN(K1,N)
     &                 -LXR_CI*T_DELT_EIGEN(K2,N)
               HOM2CR = MXR_CR
               SHOM_CR = SHOM_CR + HOM1CR + HOM2CR
             ENDDO
             STOTAL = SPAR + SHOM_R + SHOM_CR
             STOKES_DOWNSURF(I,O1) =  QUAD_STRMWTS(I) * STOTAL
           ENDDO
         ENDDO
        ENDIF

C  reflected multiple scatter intensity at user defined-angles

        IF ( FOURIER_COMPONENT .EQ. 0 ) THEN
          KMULT = SURFACE_FACTOR * LAMBERTIAN_ALBEDO
          O1 = 1
          REFLEC = ZERO
          DO J = 1, NSTREAMS
            REFLEC = REFLEC + STOKES_DOWNSURF(J,O1)
          ENDDO
          IF ( DO_QTHTONLY ) THEN
            DO I = 1, NSTREAMS
              BOA_THTONLY_SOURCE(I) = REFLEC
            ENDDO
          ENDIF
          REFLEC = KMULT * REFLEC
          DO UM = LOCAL_UM_START, N_USER_STREAMS
            BOA_DIFFUSE_SOURCE(UM,O1) = REFLEC
          ENDDO
        ENDIF

C  Add direct beam if flagged
C   Addition of the DBCORRECTION clause is now required

        IF ( DO_INCLUDE_DIRECTBEAM.AND..NOT.DO_DBCORRECTION ) THEN
          DO UM = LOCAL_UM_START, N_USER_STREAMS
            DO O1 = 1, NSTOKES
              BOA_DIRECT_SOURCE(UM,O1) = USER_DIRECT_BEAM(UM,IBEAM,O1)
            ENDDO
          ENDDO
        ENDIF

C  End inclusion of surface terms

      ENDIF

C  Add surface emission term if flagged

      IF ( DO_INCLUDE_SURFEMISS ) THEN
        FP_SBB = SURFBB
        IF ( DO_SOLAR_SOURCES ) FP_SBB = PI4 * SURFBB
        if ( do_lambertian_surface ) then
          o1 = 1
          local_emiss = FP_SBB * ( one - lambertian_albedo )
          DO UM = LOCAL_UM_START, N_USER_STREAMS
              BOA_DIFFUSE_SOURCE(UM,O1) =
     &      BOA_DIFFUSE_SOURCE(UM,O1) + LOCAL_EMISS
          ENDDO
        else
          DO UM = LOCAL_UM_START, N_USER_STREAMS
            DO O1 = 1, NSTOKES
              BOA_DIFFUSE_SOURCE(UM,O1) =
     &        BOA_DIFFUSE_SOURCE(UM,O1) + FP_SBB*USER_EMISSIVITY(UM,O1)
            ENDDO
          ENDDO
        endif
        IF ( DO_QTHTONLY ) THEN
          if ( do_lambertian_surface ) then
            o1 = 1
            local_emiss = FP_SBB * ( one - lambertian_albedo )
            DO I = 1, NSTREAMS
              BOA_THTONLY_SOURCE(I) = BOA_THTONLY_SOURCE(I)+LOCAL_EMISS
            ENDDO
          else
            DO I = 1, NSTREAMS
              DO O1 = 1, NSTOKES
                BOA_THTONLY_SOURCE(I) = BOA_THTONLY_SOURCE(I) +
     &                 FP_SBB * EMISSIVITY(I,O1)
              ENDDO
            ENDDO
          endif
        ENDIF
      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE WHOLELAYER_STERM_UP
     I   ( N, M, IBEAM, SOURCETERM_FLAG, DO_INCLUDE_THERMEMISS,
     O     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 main solution and multiplier variables (input/output)

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

C  include file of thermal variables

      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  arguments
C  ---------

C  input control

      INTEGER          N, M, IBEAM
      LOGICAL          SOURCETERM_FLAG
      LOGICAL          DO_INCLUDE_THERMEMISS

C  Output

      DOUBLE PRECISION LAYERSOURCE      (MAX_USER_STREAMS,MAXSTOKES)

C  local variables

      LOGICAL          L1
      INTEGER          UM, O1, K, KO1, K0, K1, K2, M1
      DOUBLE PRECISION H_R, H_CR, SFOR1, SFOR2, TM
      DOUBLE PRECISION LUXR, MUXR, LUX_CR, LUX_CI, MUX_CR, MUX_CI

C  Fourier number (debug only)

      M1 = M
      L1 = SOURCETERM_FLAG

C   Very important to zero output term (bug solved 04/20/05)

      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          LAYERSOURCE(UM,O1)       = ZERO
        ENDDO
      ENDDO

C  Avoid this section if thermal transmittance only

      IF ( DO_THERMAL_TRANSONLY ) GO TO 6789

C  Offset

      KO1 = K_REAL(N) + 1

C  Whole layer source function Homogeneous only

      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          H_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)
            H_R = H_R + LUXR * HMULT_2(K,UM,N) +
     &                  MUXR * HMULT_1(K,UM,N)
          ENDDO
          H_CR = ZERO
          DO K = 1, K_COMPLEX(N)
            K0 = 2*K-2
            K1 = KO1 + K0
            K2 = K1  + 1
            LUX_CR = LCON(K1,N) * UHOM_UPDN(UM,O1,K1,N) -
     &               LCON(K2,N) * UHOM_UPDN(UM,O1,K2,N)
            LUX_CI = LCON(K1,N) * UHOM_UPDN(UM,O1,K2,N) +
     &               LCON(K2,N) * UHOM_UPDN(UM,O1,K1,N)
            MUX_CR = MCON(K1,N) * UHOM_UPUP(UM,O1,K1,N) -
     &               MCON(K2,N) * UHOM_UPUP(UM,O1,K2,N)
            MUX_CI = MCON(K1,N) * UHOM_UPUP(UM,O1,K2,N) +
     &               MCON(K2,N) * UHOM_UPUP(UM,O1,K1,N)
            H_CR = H_CR + LUX_CR * HMULT_2(K1,UM,N) -
     &                    LUX_CI * HMULT_2(K2,UM,N) +
     &                    MUX_CR * HMULT_1(K1,UM,N) -
     &                    MUX_CI * HMULT_1(K2,UM,N)
          ENDDO
          LAYERSOURCE(UM,O1) = H_R + H_CR
        ENDDO
      ENDDO

C  Continuation point

 6789 continue

C  Add thermal emission term (direct and diffuse)
C     Modulus 4.pi if solar sources are included (taken care of earlier)

      IF ( DO_INCLUDE_THERMEMISS ) THEN
        TM = ONE
        O1 = 1
         DO UM = LOCAL_UM_START, N_USER_STREAMS
          LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) +
     &              LAYER_TSUP_UP(UM,N)*TM
        ENDDO
      ENDIF

C  nothing more to do if no solar sources

      IF ( .NOT. DO_SOLAR_SOURCES ) RETURN

C  Add particular integral contribution (solar term)

      IF ( DO_CLASSICAL_SOLUTION ) THEN
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            SFOR2 =  EMULT_UP(UM,N,IBEAM) * UPAR_UP_2(UM,O1,N)
            LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) + SFOR2
          ENDDO
        ENDDO
      ELSE
C  PLACEHOLDER FOR GREENS FUNCTION
      ENDIF

C  If operating in Ms-mode only, finished

      IF ( DO_MSMODE_VLIDORT ) RETURN

C  Full radiance mode, add single scatter part

      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          SFOR1 = UPAR_UP_1(UM,O1,N) * EMULT_UP(UM,N,IBEAM)
          LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) + SFOR1
        ENDDO
      ENDDO

C  debug. NSTOKES = 1 checks out.

c      DO UM = LOCAL_UM_START, N_USER_STREAMS
c        write(*,*)N,um, LAYERSOURCE(UM,1), EMULT_UP(UM,N,IBEAM)
c      ENDDO
c      if (n.eq.1)pause

C  Finish

      RETURN
      END

C

      SUBROUTINE WHOLELAYER_STERM_DN
     I    ( N, IBEAM, SOURCETERM_FLAG, DO_INCLUDE_THERMEMISS,
     O      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 main solution and multiplier variables (input/output)

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

C  include file of thermal variables

      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  arguments
C  ---------

C  Control input

      INTEGER          N, IBEAM
      LOGICAL          SOURCETERM_FLAG
      LOGICAL          DO_INCLUDE_THERMEMISS

C  Output

      DOUBLE PRECISION LAYERSOURCE(MAX_USER_STREAMS,MAXSTOKES)

C  local variables

      LOGICAL          L1
      INTEGER          UM, O1, K, KO1, K0, K1, K2
      DOUBLE PRECISION H_R, H_CR, SFOR1, SFOR2, TM
      DOUBLE PRECISION LUXR, MUXR, LUX_CR, LUX_CI, MUX_CR, MUX_CI

C  Zeroing is very important here

      L1 = SOURCETERM_FLAG
      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          LAYERSOURCE(UM,O1)       = ZERO
        ENDDO
      ENDDO

C  Avoid this section if thermal transmittance only

      IF ( DO_THERMAL_TRANSONLY ) GO TO 6789

C  Offest

      KO1 = K_REAL(N) + 1

C  Whole layer source function, homoegeneous solution contribution

      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          H_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)
            H_R = H_R + LUXR * HMULT_1(K,UM,N) +
     &                  MUXR * HMULT_2(K,UM,N)
          ENDDO
          H_CR = ZERO
          DO K = 1, K_COMPLEX(N)
            K0 = 2*K-2
            K1 = KO1 + K0
            K2 = K1  + 1
            LUX_CR = LCON(K1,N) * UHOM_DNDN(UM,O1,K1,N) -
     &               LCON(K2,N) * UHOM_DNDN(UM,O1,K2,N)
            LUX_CI = LCON(K1,N) * UHOM_DNDN(UM,O1,K2,N) +
     &               LCON(K2,N) * UHOM_DNDN(UM,O1,K1,N)
            MUX_CR = MCON(K1,N) * UHOM_DNUP(UM,O1,K1,N) -
     &               MCON(K2,N) * UHOM_DNUP(UM,O1,K2,N)
            MUX_CI = MCON(K1,N) * UHOM_DNUP(UM,O1,K2,N) +
     &               MCON(K2,N) * UHOM_DNUP(UM,O1,K1,N)
            H_CR = H_CR + LUX_CR * HMULT_1(K1,UM,N) -
     &                    LUX_CI * HMULT_1(K2,UM,N) +
     &                    MUX_CR * HMULT_2(K1,UM,N) -
     &                    MUX_CI * HMULT_2(K2,UM,N)
          ENDDO
          LAYERSOURCE(UM,O1) = H_R + H_CR
        ENDDO
      ENDDO

C  Continuation point

 6789 continue

C  Add thermal emission term (direct and diffuse)

      IF ( DO_INCLUDE_THERMEMISS ) THEN
        TM = ONE
        O1 = 1
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1)
     &                           + LAYER_TSUP_DN(UM,N)*TM
        ENDDO
      ENDIF

C  nothing more to do is no solar sources

      IF ( .NOT. DO_SOLAR_SOURCES ) RETURN

C  Particular integral contribution

      IF ( DO_CLASSICAL_SOLUTION ) THEN
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            SFOR2 =  EMULT_DN(UM,N,IBEAM) * UPAR_DN_2(UM,O1,N)
            LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) + SFOR2
          ENDDO
        ENDDO
      ELSE
C  PLACEHOLDER GREENS FUNCTION
      ENDIF

C  If operating in Ms-mode only, finished

      IF ( DO_MSMODE_VLIDORT ) RETURN

C  Full radiance mode, add single scatter part

      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          SFOR1 = UPAR_DN_1(UM,O1,N) * EMULT_DN(UM,N,IBEAM)
          LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) + SFOR1
        ENDDO
      ENDDO

C  Finish

      RETURN
      END

C

      SUBROUTINE PARTLAYER_STERM_UP
     I  ( N, UT, IBEAM, SOURCETERM_FLAG, DO_INCLUDE_THERMEMISS,
     O    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 main solution and multiplier variables (input/output)

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

C  include file of thermal variables

      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  arguments
C  ---------

C  Control input

      INTEGER          N, IBEAM
      LOGICAL          SOURCETERM_FLAG
      LOGICAL          DO_INCLUDE_THERMEMISS

C  Output

      DOUBLE PRECISION LAYERSOURCE(MAX_USER_STREAMS,MAXSTOKES)

C  local variables

      LOGICAL          L1
      INTEGER          UM, UT, O1, K, KO1, K0, K1, K2
      DOUBLE PRECISION H_R, H_CR, SFOR1, SFOR2, TM
      DOUBLE PRECISION LUXR, MUXR, LUX_CR, LUX_CI, MUX_CR, MUX_CI

C  Zeroing is very important here

      SFOR2 = ZERO
      L1 = SOURCETERM_FLAG
      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          LAYERSOURCE(UM,O1)       = ZERO
        ENDDO
      ENDDO

C  Avoid this section if thermal transmittance only

      IF ( DO_THERMAL_TRANSONLY ) GO TO 6789

C  Offset

      KO1 = K_REAL(N) + 1

C  Whole layer source function, homogeneous contribution

      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          H_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)
            H_R = H_R + LUXR * UT_HMULT_UD(K,UM,UT) +
     &                  MUXR * UT_HMULT_UU(K,UM,UT)
          ENDDO
          H_CR = ZERO
          DO K = 1, K_COMPLEX(N)
            K0 = 2*K-2
            K1 = KO1 + K0
            K2 = K1  + 1
            LUX_CR = LCON(K1,N) * UHOM_UPDN(UM,O1,K1,N) -
     &               LCON(K2,N) * UHOM_UPDN(UM,O1,K2,N)
            LUX_CI = LCON(K1,N) * UHOM_UPDN(UM,O1,K2,N) +
     &               LCON(K2,N) * UHOM_UPDN(UM,O1,K1,N)
            MUX_CR = MCON(K1,N) * UHOM_UPUP(UM,O1,K1,N) -
     &               MCON(K2,N) * UHOM_UPUP(UM,O1,K2,N)
            MUX_CI = MCON(K1,N) * UHOM_UPUP(UM,O1,K2,N) +
     &               MCON(K2,N) * UHOM_UPUP(UM,O1,K1,N)
            H_CR = H_CR + LUX_CR * UT_HMULT_UD(K1,UM,UT) -
     &                    LUX_CI * UT_HMULT_UD(K2,UM,UT) +
     &                    MUX_CR * UT_HMULT_UU(K1,UM,UT) -
     &                    MUX_CI * UT_HMULT_UU(K2,UM,UT)
          ENDDO
          LAYERSOURCE(UM,O1) = H_R + H_CR
        ENDDO
      ENDDO

C  Continuation point

 6789 continue

C  Add thermal term (direct and diffuse)

      IF ( DO_INCLUDE_THERMEMISS ) THEN
        TM = ONE
        O1 = 1
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) +
     &                   LAYER_TSUP_UTUP(UM,UT)*TM
        ENDDO
      ENDIF

C  nothing more to do is no solar sources

      IF ( .NOT. DO_SOLAR_SOURCES ) RETURN

C  Particular integral contribution

      IF ( DO_CLASSICAL_SOLUTION ) THEN
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            SFOR2 =  UT_EMULT_UP(UM,UT,IBEAM) * UPAR_UP_2(UM,O1,N)
            LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) + SFOR2
          ENDDO
        ENDDO
      ELSE
C  PLACEHOLDER GREENS FUNCTION
      ENDIF

C  If NOT operating in Ms-mode only, add single scatter part

      IF ( .NOT. DO_MSMODE_VLIDORT ) THEN
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            SFOR1 = UT_EMULT_UP(UM,UT,IBEAM) * UPAR_UP_1(UM,O1,N)
            LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) + SFOR1
          ENDDO
        ENDDO
      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE PARTLAYER_STERM_DN
     I  ( N, UT, IBEAM, SOURCETERM_FLAG, DO_INCLUDE_THERMEMISS,
     O    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 main solution and multiplier variables (input/output)

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

C  include file of thermal variables

      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  arguments
C  ---------

C  Control input

      INTEGER          N, IBEAM
      LOGICAL          SOURCETERM_FLAG
      LOGICAL          DO_INCLUDE_THERMEMISS

C  Output

      DOUBLE PRECISION LAYERSOURCE(MAX_USER_STREAMS,MAXSTOKES)

C  local variables

      LOGICAL          L1
      INTEGER          UM, UT, O1, K, KO1, K0, K1, K2
      DOUBLE PRECISION H_R, H_CR, SFOR1, SFOR2, TM
      DOUBLE PRECISION LUXR, MUXR, LUX_CR, LUX_CI, MUX_CR, MUX_CI

C  Zeroing is very important here

      SFOR2 = ZERO
      L1 = SOURCETERM_FLAG
      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          LAYERSOURCE(UM,O1)       = ZERO
        ENDDO
      ENDDO

C  Avoid this section if thermal transmittance only

      IF ( DO_THERMAL_TRANSONLY ) GO TO 6789

C  Offset

      KO1 = K_REAL(N) + 1

C  Whole layer source function, homogeneous contribution

      DO UM = LOCAL_UM_START, N_USER_STREAMS
        DO O1 = 1, NSTOKES
          H_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)
            H_R = H_R + LUXR * UT_HMULT_DD(K,UM,UT) +
     &                  MUXR * UT_HMULT_DU(K,UM,UT)
          ENDDO
          H_CR = ZERO
          DO K = 1, K_COMPLEX(N)
            K0 = 2*K-2
            K1 = KO1 + K0
            K2 = K1  + 1
            LUX_CR = LCON(K1,N) * UHOM_DNDN(UM,O1,K1,N) -
     &               LCON(K2,N) * UHOM_DNDN(UM,O1,K2,N)
            LUX_CI = LCON(K1,N) * UHOM_DNDN(UM,O1,K2,N) +
     &               LCON(K2,N) * UHOM_DNDN(UM,O1,K1,N)
            MUX_CR = MCON(K1,N) * UHOM_DNUP(UM,O1,K1,N) -
     &               MCON(K2,N) * UHOM_DNUP(UM,O1,K2,N)
            MUX_CI = MCON(K1,N) * UHOM_DNUP(UM,O1,K2,N) +
     &               MCON(K2,N) * UHOM_DNUP(UM,O1,K1,N)
            H_CR = H_CR + LUX_CR * UT_HMULT_DD(K1,UM,UT) -
     &                    LUX_CI * UT_HMULT_DD(K2,UM,UT) +
     &                    MUX_CR * UT_HMULT_DU(K1,UM,UT) -
     &                    MUX_CI * UT_HMULT_DU(K2,UM,UT)
          ENDDO
          LAYERSOURCE(UM,O1) = SFOR2 + H_R + H_CR
        ENDDO
      ENDDO

C  Continuation point

 6789 continue

C  Add thermal term (direct and diffuse)

      IF ( DO_INCLUDE_THERMEMISS ) THEN
        TM = ONE
        O1 = 1
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) +
     &                   LAYER_TSUP_UTDN(UM,UT)*TM
        ENDDO
      ENDIF

C  nothing more to do is no solar sources

      IF ( .NOT. DO_SOLAR_SOURCES ) RETURN

C  Particular integral contribution

      IF ( DO_CLASSICAL_SOLUTION ) THEN
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            SFOR2 =  UT_EMULT_DN(UM,UT,IBEAM) * UPAR_DN_2(UM,O1,N)
            LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) + SFOR2
       ENDDO
        ENDDO
      ELSE
C  PLACEHOLDER GREENS FUNCTION
      ENDIF

C  If NOT operating in Ms-mode only, add single scatter part

      IF ( .NOT. DO_MSMODE_VLIDORT ) THEN
        DO UM = LOCAL_UM_START, N_USER_STREAMS
          DO O1 = 1, NSTOKES
            SFOR1 = UT_EMULT_DN(UM,UT,IBEAM) * UPAR_DN_1(UM,O1,N)
            LAYERSOURCE(UM,O1) = LAYERSOURCE(UM,O1) + SFOR1
          ENDDO
        ENDDO
      ENDIF

C  Finish

      RETURN
      END


      Program DRIVER
c**************************************************************************
c     This is the driver for the whole calulation
c**************************************************************************
      implicit none
C
C     CONSTANTS
C
      double precision pi, zero
      parameter (pi=3.1415926535897932385d0)
      parameter (zero = 0d0)
      integer npoints, npointsChecked
      integer i, j, k
      integer return_code
      double precision tolerance, tolerance_default
      double precision, allocatable :: accuracies(:)
      double precision accuracy2
      double precision ren_scale, energy
      include 'genps.inc'
      include 'nexternal.inc'
      include 'nFKSconfigs.inc'
      double precision p(0:3, nexternal), prambo(0:3,100)
      double precision p_born(0:3,nexternal-1)
      common/pborn/p_born
      double precision pswgt
      double precision fks_double, fks_single
      double precision, allocatable :: virt_wgts(:,:)
      double precision double, single, finite
      double complex born(2)
      double precision totmass
      logical calculatedborn
      common/ccalculatedborn/calculatedborn
      logical fksprefact
      parameter (fksprefact=.true.)
      integer nfksprocess
      common/c_nfksprocess/nfksprocess
      double precision fkssymmetryfactor,fkssymmetryfactorBorn,
     &     fkssymmetryfactorDeg
      integer ngluons,nquarks(-6:6)
      common/numberofparticles/fkssymmetryfactor,fkssymmetryfactorBorn,
     &                         fkssymmetryfactorDeg,ngluons,nquarks
      integer fks_j_from_i(nexternal,0:nexternal)
     &     ,particle_type(nexternal),pdg_type(nexternal)
      common /c_fks_inc/fks_j_from_i,particle_type,pdg_type
      integer i_fks,j_fks
      common/fks_indices/i_fks,j_fks
cc
      include 'run.inc'
      include 'coupl.inc'
      include 'q_es.inc'
      integer nsqso
      double precision pmass(nexternal), pmass_rambo(100)
      integer nfail
      logical first_time
      data first_time/.TRUE./
      include 'FKSParams.inc'
      include 'mint.inc'

C-----
C  BEGIN CODE
C-----
      if (first_time) then
          call get_nsqso_loop(nsqso)
          allocate(virt_wgts(0:3,0:nsqso))
          allocate(accuracies(0:nsqso))
          first_time = .false.
      endif

      call setrun                !Sets up run parameters
      call setpara('param_card.dat')   !Sets up couplings and masses
      call setcuts               !Sets up cuts and particle masses
      call printout              !Prints out a summary of paramaters
      call run_printout          !Prints out a summary of the run settings
      include 'pmass.inc'

      call FKSParamReader('FKS_params.dat',.TRUE.,.FALSE.)
      tolerance_default = IRPoleCheckThreshold

c     Set the energy to be characteristic of the run
      totmass = 0.0d0
      do i=1,nexternal
        totmass = totmass + pmass(i)
      enddo
      energy = max((ebeam(1)+ebeam(2))/20.0d0,2.0d0*totmass)
c     Set the renormalization scale to be of the order of sqrt(s) but
c     not equal to it so as to be sensitive to all logs in the check.
      ren_scale = energy/2.0d0

      write(*,*)' Insert the number of points to test'
      read(*,*) npoints
      write(*,*)'Insert the relative tolerance'
      write(*,*)' A negative number will mean use the default one: ',
     1 tolerance_default
      read(*,*) tolerance
      if (tolerance .le. zero) tolerance = tolerance_default

      mu_r = ren_scale
      qes2 = ren_scale**2

      do i = nincoming+1, nexternal-1
          pmass_rambo(i-nincoming) = pmass(i)
      enddo

      iconfig=1
      ichan=1
      iconfigs(1)=iconfig
c Find the nFKSprocess for which we compute the Born-like contributions,
c ie. which is a Born+g real-emission process
      do nFKSprocess=1,fks_configs
         call fks_inc_chooser()
         if (particle_type(i_fks).eq.8) exit
      enddo
      call fks_inc_chooser()
      call leshouche_inc_chooser()
      call setfksfactor(1,.false.)

      nfail = 0
      npointsChecked = 0

c Make sure that stability checks are always used by MadLoop, even for
c initialization
      CALL FORCE_STABILITY_CHECK(.TRUE.)
      CALL COLLIER_COMPUTE_UV_POLES(.TRUE.)
      CALL COLLIER_COMPUTE_IR_POLES(.TRUE.)

200   continue
          calculatedborn = .false.
          if (nincoming.eq.1) then
              call rambo(0, nexternal-nincoming-1, pmass(1),
     1         pmass_rambo, prambo)
              p_born(0,1) = pmass(1)
              p_born(1,1) = 0d0
              p_born(2,1) = 0d0
              p_born(3,1) = 0d0
          elseif (nincoming.eq.2) then
              if (nexternal - nincoming - 1 .eq.1) then
                  ! deal with the case of only one particle in the final
                  ! state
                  p_born(0,1) = pmass(3)/2d0
                  p_born(1,1) = 0d0
                  p_born(2,1) = 0d0
                  p_born(3,1) = pmass(3)/2d0
                  if (pmass(1) > 0d0)
     1               p_born(3,1) = dsqrt(pmass(3)**2/4d0 - pmass(1)**2)
                  p_born(0,2) = pmass(3)/2d0
                  p_born(1,2) = 0d0
                  p_born(2,2) = 0d0
                  p_born(3,2) = -pmass(3)/2d0
                  if (pmass(2) > 0d0)
     1               p_born(3,2) = -dsqrt(pmass(3)**2/4d0 - pmass(1)**2)

                  prambo(0,1) = pmass(3)
                  prambo(1,1) = 0d0
                  prambo(2,1) = 0d0
                  prambo(3,1) = 0d0

              else

                  call rambo(0, nexternal-nincoming-1, energy,
     1             pmass_rambo, prambo)
                  p_born(0,1) = energy/2d0
                  p_born(1,1) = 0d0
                  p_born(2,1) = 0d0
                  p_born(3,1) = energy/2d0
                  if (pmass(1) > 0d0)
     1               p_born(3,1) = dsqrt(energy**2/4d0 - pmass(1)**2)
                  p_born(0,2) = energy/2
                  p_born(1,2) = 0d0
                  p_born(2,2) = 0d0
                  p_born(3,2) = -energy/2d0
                  if (pmass(2) > 0d0)
     1               p_born(3,2) = -dsqrt(energy**2/4d0 - pmass(1)**2)
              endif
          else
              write(*,*) 'INVALID NUMBER OF INCOMING PARTICLES',
     1          nincoming
              stop
          endif

          do j = 0, 3
            do k = nincoming+1, nexternal-1
              p_born(j,k) = prambo(j,k-nincoming)
            enddo
          enddo

          CALL UPDATE_AS_PARAM()
          call sborn(p_born, born)
          call sloopmatrix_thres(p_born,virt_wgts,tolerance,
     1 accuracies,return_code)
          accuracy2=accuracies(0)

          finite = virt_wgts(1,0)
          single = virt_wgts(2,0)
          double = virt_wgts(3,0)

C         If MadLoop was still in initialization mode, then skip this
C         point for the checks
          if (accuracy2.lt.0.0d0) goto 200
C         Otherwise, perform the check
          npointsChecked = npointsChecked +1

          do j = 0, 3
            do k = 1, nexternal - 1
              p(j,k) = p_born(j,k)
            enddo
            p(j, nexternal) = 0d0
          enddo

          call getpoles(p, mu_r**2, fks_double, fks_single, fksprefact)

          if ( tolerance.lt.0.0d0 ) then
                write(*,*) 'PASSED', tolerance
          else
          if ( double.ne.0d0 ) then
             if ((dabs((double-fks_double)/double).gt.tolerance).or.
     1            (dabs((single-fks_single)/single).gt.tolerance)) then
                nfail = nfail + 1
                write(*,*) 'FAILED', tolerance
             else
                write(*,*) 'PASSED', tolerance
             endif
          elseif ( fks_double.ne.0d0 ) then
             if ((dabs((double-fks_double)/fks_double).gt.tolerance).or.
     1            (dabs((single-fks_single)/single).gt.tolerance)) then
                nfail = nfail + 1
                write(*,*) 'FAILED', tolerance
             else
                write(*,*) 'PASSED', tolerance
             endif
          else
             if (dabs((single-fks_single)/single).gt.tolerance) then
                nfail = nfail + 1
                write(*,*) 'FAILED', tolerance
             else
                write(*,*) 'PASSED', tolerance
             endif
          endif
          endif
          write(*,*) 'MU_R    = ', ren_scale
          write(*,*) 'ALPHA_S = ', G**2/4d0/pi
          write(*,*) 'BORN                 ', real(born(1))
          write(*,*) 'SINGLE POLE (MadFKS) ', fks_single
          write(*,*) 'DOUBLE POLE (MadFKS) ', fks_double
          write(*,*) 'SINGLE POLE (MadLoop)', single
          write(*,*) 'DOUBLE POLE (MadLoop)', double
          write(*,*) 'FINITE PART (MadLoop)', finite
          do j = 1, nexternal - 1
            write(*,*) p(0,j), p(1,j), p(2,j), p(3,j), pmass(j)
          enddo
          write(*,*)

      if (npointsChecked.lt.npoints) goto 200

          write(*,*) 'NUMBER OF POINTS PASSING THE CHECK',
     1     npoints - nfail
          write(*,*) 'NUMBER OF POINTS FAILING THE CHECK',
     1     nfail
          write(*,*) 'TOLERANCE ', tolerance

      return
      end

      SUBROUTINE RAMBO(LFLAG,N,ET,XM,P)
c------------------------------------------------------
c
c                       RAMBO
c
c    RA(NDOM)  M(OMENTA)  B(EAUTIFULLY)  O(RGANIZED)
c
c    A DEMOCRATIC MULTI-PARTICLE PHASE SPACE GENERATOR
c    AUTHORS:  S.D. ELLIS,  R. KLEISS,  W.J. STIRLING
c    THIS IS VERSION 1.0 -  WRITTEN BY R. KLEISS
c    (MODIFIED BY R. PITTAU)
c
c                INPUT                 OUTPUT
c
c    LFLAG= 0:   N, ET, XM             P, (DJ)
c    LFLAG= 1:   N, ET, XM, P          (DJ)
c
c    N  = NUMBER OF PARTICLES (>1, IN THIS VERSION <101)
c    ET = TOTAL CENTRE-OF-MASS ENERGY
c    XM = PARTICLE MASSES ( DIM=100 )
c    P  = PARTICLE MOMENTA ( DIM=(4,100) )
c    DJ = 1/(WEIGHT OF THE EVENT)
c
c------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION XM(100),P(0:3,100),Q(4,100),Z(100),R(4),
     .   B(3),P2(100),XM2(100),E(100),V(100),IWARN(5)
      SAVE ACC,ITMAX,IBEGIN,IWARN,Z,TWOPI,PO2LOG
      DATA ACC/1.D-14/,ITMAX/10/,IBEGIN/0/,IWARN/5*0/
C
C INITIALIZATION STEP: FACTORIALS FOR THE PHASE SPACE WEIGHT
      IF(IBEGIN.NE.0) GOTO 103
      IBEGIN=1
      TWOPI=8.*DATAN(1.D0)
      PO2LOG=LOG(TWOPI/4.)
      Z(2)=PO2LOG
      DO 101 K=3,100
  101 Z(K)=Z(K-1)+PO2LOG-2.*LOG(DFLOAT(K-2))
      DO 102 K=3,100
  102 Z(K)=(Z(K)-LOG(DFLOAT(K-1)))
C
C CHECK ON THE NUMBER OF PARTICLES
  103 IF(N.GT.1.AND.N.LT.101) GOTO 104
      PRINT 1001,N
      STOP
C
C CHECK WHETHER TOTAL ENERGY IS SUFFICIENT; COUNT NONZERO MASSES
  104 XMT=0.
      NM=0
      DO 105 I=1,N
      IF(XM(I).NE.0.D0) NM=NM+1
  105 XMT=XMT+ABS(XM(I))
      IF(XMT.LE.ET) GOTO 201
      PRINT 1002,XMT,ET
      STOP

  201 CONTINUE
      if (lflag.eq.1) then
        w0= exp((2.*N-4.)*LOG(ET)+Z(N))
        do j= 1,N
          v(j)= sqrt(p(1,j)**2+p(2,j)**2+p(3,j)**2)
        enddo

        a1= 0.d0
        a3= 0.d0
        a2= 1.d0
        do j= 1,N
          a1= a1+v(j)/ET
          a2= a2*v(j)/p(0,j)
          a3= a3+v(j)*v(j)/p(0,j)/ET
        enddo
        wm= a1**(2*N-3)*a2/a3
        dj= 1.d0/w0/wm
        return
      endif
C
C THE PARAMETER VALUES ARE NOW ACCEPTED
C
C GENERATE N MASSLESS MOMENTA IN INFINITE PHASE SPACE

      DO 202 I=1,N
      call rans(RAN1)
      call rans(RAN2)
      call rans(RAN3)
      call rans(RAN4)
      C=2.*RAN1-1.
      S=SQRT(1.-C*C)
      F=TWOPI*RAN2
      Q(4,I)=-LOG(RAN3*RAN4)
      Q(3,I)=Q(4,I)*C
      Q(2,I)=Q(4,I)*S*COS(F)
  202 Q(1,I)=Q(4,I)*S*SIN(F)
C
C CALCULATE THE PARAMETERS OF THE CONFORMAL TRANSFORMATION
      DO 203 I=1,4
  203 R(I)=0.
      DO 204 I=1,N
      DO 204 K=1,4
  204 R(K)=R(K)+Q(K,I)
      RMAS=SQRT(R(4)**2-R(3)**2-R(2)**2-R(1)**2)
      DO 205 K=1,3
  205 B(K)=-R(K)/RMAS
      G=R(4)/RMAS
      A=1./(1.+G)
      X=ET/RMAS
C
C TRANSFORM THE Q'S CONFORMALLY INTO THE P'S
      DO 207 I=1,N
      BQ=B(1)*Q(1,I)+B(2)*Q(2,I)+B(3)*Q(3,I)
      DO 206 K=1,3
  206 P(K,I)=X*(Q(K,I)+B(K)*(Q(4,I)+A*BQ))
  207 P(0,I)=X*(G*Q(4,I)+BQ)
C
C CALCULATE WEIGHT AND POSSIBLE WARNINGS
      WT=PO2LOG
      IF(N.NE.2) WT=(2.*N-4.)*LOG(ET)+Z(N)
      IF(WT.GE.-180.D0) GOTO 208
      IF(IWARN(1).LE.5) PRINT 1004,WT
      IWARN(1)=IWARN(1)+1
  208 IF(WT.LE. 174.D0) GOTO 209
      IF(IWARN(2).LE.5) PRINT 1005,WT
      IWARN(2)=IWARN(2)+1
C
C RETURN FOR WEIGHTED MASSLESS MOMENTA
  209 IF(NM.NE.0) GOTO 210
      WT=EXP(WT)
      DJ= 1.d0/WT
      RETURN
C
C MASSIVE PARTICLES: RESCALE THE MOMENTA BY A FACTOR X
  210 XMAX=SQRT(1.-(XMT/ET)**2)
      DO 301 I=1,N
      XM2(I)=XM(I)**2
  301 P2(I)=P(0,I)**2
      ITER=0
      X=XMAX
      ACCU=ET*ACC
  302 F0=-ET
      G0=0.
      X2=X*X
      DO 303 I=1,N
      E(I)=SQRT(XM2(I)+X2*P2(I))
      F0=F0+E(I)
  303 G0=G0+P2(I)/E(I)
      IF(ABS(F0).LE.ACCU) GOTO 305
      ITER=ITER+1
      IF(ITER.LE.ITMAX) GOTO 304
      PRINT 1006,ITMAX
      GOTO 305
  304 X=X-F0/(X*G0)
      GOTO 302
  305 DO 307 I=1,N
      V(I)=X*P(0,I)
      DO 306 K=1,3
  306 P(K,I)=X*P(K,I)
  307 P(0,I)=E(I)
C
C CALCULATE THE MASS-EFFECT WEIGHT FACTOR
      WT2=1.
      WT3=0.
      DO 308 I=1,N
      WT2=WT2*V(I)/E(I)
  308 WT3=WT3+V(I)**2/E(I)
      WTM=(2.*N-3.)*LOG(X)+LOG(WT2/WT3*ET)
C
C RETURN FOR  WEIGHTED MASSIVE MOMENTA
      WT=WT+WTM
      IF(WT.GE.-180.D0) GOTO 309
      IF(IWARN(3).LE.5) PRINT 1004,WT
      IWARN(3)=IWARN(3)+1
  309 IF(WT.LE. 174.D0) GOTO 310
      IF(IWARN(4).LE.5) PRINT 1005,WT
      IWARN(4)=IWARN(4)+1
  310 WT=EXP(WT)
      DJ= 1.d0/WT
      RETURN
C
 1001 FORMAT(' RAMBO FAILS: # OF PARTICLES =',I5,' IS NOT ALLOWED')
 1002 FORMAT(' RAMBO FAILS: TOTAL MASS =',D15.6,' IS NOT',
     . ' SMALLER THAN TOTAL ENERGY =',D15.6)
 1004 FORMAT(' RAMBO WARNS: WEIGHT = EXP(',F20.9,') MAY UNDERFLOW')
 1005 FORMAT(' RAMBO WARNS: WEIGHT = EXP(',F20.9,') MAY  OVERFLOW')
 1006 FORMAT(' RAMBO WARNS:',I3,' ITERATIONS DID NOT GIVE THE',
     . ' DESIRED ACCURACY =',D15.6)
      END

      subroutine rans(rand)
c     Just a wrapper to ran2
      implicit none
      double precision rand, ran2
      rand = ran2()
      return
      end

      subroutine outfun(p, a, b, i)
c     just a dummy subroutine
      implicit none
      include 'nexternal.inc'
      double precision p(0:3, nexternal), a, b
      integer i
      write(*,*) 'THIS FUNCTION SHOULD NEVER BE CALLED'
      return
      end

      subroutine initplot
      end


C     CALCULATE ROTOR EXIT SECTOR FLOW
      SUBROUTINE FLOW2(I)
C
      REAL MFSTOP
      LOGICAL PREVER
      COMMON /SNTCP/G,AJ,PRPC,ICASE,PREVER,MFSTOP,JUMP,LOPIN,ISCASE,
     1 K,GAMF,IP,SCRIT,PTRN,ISECT,KSTG,WTOL,RHOTOL,PRTOL,TRLOOP,LSTG,
     2LBRC,IBRC,ICHOKE,ISORR,CHOKE,PT0PS1(6,8),PTRS2(6,8),TRDIAG,SC,RC,
     3DELPR,PASS,IPC,LOPC,ISS
C
      COMMON /SINIT/H1(6,8),H2(6,8),DP0(6,8),DP1(6,8),DP1A(6,8),DP2(6,8)
     1,DP2A(6,8),CSALF1(6,8),ALF1(6,8),CSBET2(6,8),BET2(6,8),RADSD(6,8),
     2RADRD(6,8),ANN1(6,8),ANN2(6,8),ANN2A(6,8),ANN1A(6,8),U1A(6,8),
     3U2(6,8),ANN0(6,8),PT0(6,8),TT0(6,8),ALPHA0(6,8),PTP(6,8)
C
      COMMON /SINPUT/
     1PTPS,PTIN,TTIN,WAIR,FAIR,DELC,DELL,DELA,AACS,VCTD,STG,SECT,EXPN,
     2EXPP,EXPRE,RG,RPM,PAF,SLI,STGCH,ENDJOB,XNAME(20),TITLE(20),
     3PCNH(6),GAM(6,8),DR(6,8),DT(6,8),RWG(6,8),ALPHAS(6,8),ALPHA1(6,8),
     4ETARS(6,8),ETAS(6,8),CFS(6,8),ANDO(6,8),BETA1(6,8),BETA2(6,8),ETAR
     5R(6,8),ETAR(6,8),CFR(6,8),TFR(6,8),ANDOR(6,8),OMEGAS(6,8),AS0(6,8)
     6,ASMP0(6,8),ACMN0(6,8),A1(6,8),A2(6,8),A3(6,8),A4(6,8),A5(6,8),A6(
     76,8),OMEGAR(6,8),BSIA(6,8),BSMPIA(6,8),BCMNIA(6,8),B1(6,8),B2(6,8)
     8,B3(6,8),B4(6,8),B5(6,8),B6(6,8),SESTHI(8),RERTHI(8)
     9,fairx(5,8),wairx(5,8),rg1(8),rg1a(8),rg2(8),rg2a(8)
C
      COMMON /SSTA2/V2(6,8),TTR2(6,8),PTR2(6,8),WG2(6,8),WGT2(8),TA2(8),
     1           PS2(6,8),PHI2(6,8)
C
      REAL MR2,M2     ,MF2
      COMMON /SFLOW2/TS2(6,8),CP2(8),R2(6,8),RHOS2(6,8),BET2E(6,8),RU2(6
     1,8),VU2(6,8),DPDR2(6,8),VZ2(6,8),MR2(6,8),MF2(6,8),M2(6,8)
      COMMON/DESOPT/RVU1(6,8),RVU2(6,8),WG,EPR
      dimension tangms(6,8),tangmr(6,8),tangm1(6,8),tangm2(6,8),tang0(6)
      common/slope/tangms,tangmr,tangm1,tangm2,tang0,iar,icyl
C
C
C
      ETAO1=1.
      cat2=cos(atan(tangm2(i,k)))
      EX=(GAM(4,K)-1.)/GAM(4,K)
C        ISENTROPIC ROTOR RELATIVE TEMPERATURE RATIO
      PHI2(I,K)= PTRS2(I,K)**EX
C     IF(OMEGAR(1,1))2,2,1
C     replaced by .................
      IF((OMEGAR(1,1)).LE.0.) THEN
         GO TO 2
      ELSE
         GO TO 1
      ENDIF
1     CALL LOSS2(I,K)
C        EXIT TEMPERATURES
2     IF(EPR.GT.0.) CALL ETAPR(PTRS2(I,K),ETAO1)
      ETA=ETAR(I,K)*ETAO1
      TS2(I,K)=TTR2(I,K)*(1.-ETA      *(1.-1./PHI2(I,K)))
C     IF(I-IP)6,3,6
C     replaced by .................
      IF((I-IP).NE.0) THEN
         GO TO 6
      ELSE
         GO TO 3
      ENDIF
C3     IF(    GAMF)4,4,5
C     replaced by .................
3     IF( GAMF.LE.0.) THEN
         GO TO 4
      ELSE
         GO TO 5
      ENDIF
4     TA2(K)=.5*(TTR2(I,K)+TS2(I,K))
      CALL GAMA(PTR2(I,K),TA2(K),FAIRx(4,k),WAIRx(4,k),GAM(4,K))
5     EXI=GAM(4,K)/(GAM(4,K)-1.)
      EX=1./EXI
C        CRITICAL PRESSURE RATIO
      CALL PHIM(EXI,ETA      ,PHI2C   ,P1AS2C   )
C        SPECIFIC HEAT AT CONSTANT PRESSURE
      CP2(K)=rg2(k)*EXI/AJ
C        RELATIVE EXIT VELOCITY
6     R2(I,K)=SQRT(2.*G*AJ*CP2(K)*(TTR2(I,K)-TS2(I,K)))
c      Pressure ratio correction to flow coefficient
      if (i.eq.ip) call etacf(ptrs2(i,k),p1as2c,xcf)
C        EXIT PRESSURE
      PS2(I,K)= PTR2(I,K)/ PTRS2(I,K)
C        EXIT DENSITY
      RHOS2(I,K)=144.*PS2(I,K)/(rg2(k)*TS2(I,K))
C        TEST CRITICAL PRESSURE RATIO
C     IF(RVU1(I,K))120,130,120
C     replaced by .........................
      IF((RVU1(I,K)).NE.0.) THEN
          SNBET2=(RVU2(I,K)*2./DP2(I,K)+U2(I,K))/R2(I,K)
          ASNBET=ABS(SNBET2)
          IF(ASNBET.GT.1.)SNBET2=SNBET2/(ASNBET+.01)
          CBET2E=SQRT(1.-SNBET2**2)
          BET2E(I,K)=ATAN(SNBET2/CBET2E)
      ENDIF
C120   SNBET2=(RVU2(I,K)*2./DP2(I,K)+U2(I,K))/R2(I,K)
C      ASNBET=ABS(SNBET2)
C      IF(ASNBET.GT.1.)SNBET2=SNBET2/(ASNBET+.01)
C      CBET2E=SQRT(1.-SNBET2**2)
C      BET2E(I,K)=ATAN(SNBET2/CBET2E)
C130   IF( PTRS2(I,K)-P1AS2C   )140,7,7
C     replaced by .........................
      IF(( PTRS2(I,K)-P1AS2C   ).LT.0.) GO TO 140
C
C7     IF(RVU1(I,K).NE.0.) GO TO 11
      IF(RVU1(I,K).NE.0.) GO TO 11
C     IF (IP-I) 22,8,22
C     replaced by .........................
      IF ((IP-I).NE.0) THEN
         GO TO  22
      ELSE
         GO TO 8
      ENDIF
C
C8     IF (PRPC)9,9,18
C     replaced by .........................
8     IF( PRPC.LE.0.) THEN
         GO TO  9
      ELSE
         GO TO 18
      ENDIF
9     PRPC=1.
      GO TO 18
22    IF (PTRS2(I,K).LE.PTRS2(IP,K))   GO TO 18
      GO TO 11
18    IF ((I.EQ.1).OR.(I.EQ.ISECT))  SCRIT=1.
      GO TO 11
11    CONTINUE
      IF(EPR.GT.0.)
     *CALL ETAPR(P1AS2C,ETAO1)
      ETAC=ETAR(I,K)*ETAO1
      R2C     =SQRT(2.*G*AJ*CP2(K)*TTR2(I,K)*ETAC     *(
     1PHI2C   -1.)/PHI2C  )
      TS2C     =TTR2(I,K)*(1.-ETAC     *(1.-1./PHI2C   ))
      RHOS2C     =144.*PTR2(I,K)/(rg2(k)*P1AS2C   *TS2C     )
C     IF(RVU1(I,K))15,150,15
C     replaced by ................
      IF(RVU1(I,K).NE.0.) THEN
         GO TO 15
      ELSE
         GO TO 150
      ENDIF
150   continue
      cscyl=sqrt(1./(1.+(1./csbet2(i,k)**2-1.)/cat2**2))
      WG2(I,K)=RHOS2C     *R2C     *ANN2(I,K)*CScyl
     & *cat2*cfr(i,k)*xcf
      if (andor(1,k).gt.0.0) wg2(i,k)=wg2(i,k)/cfr(i,k)/xcf
C   OVEREXPANSION
      Cscyle     =WG2(I,K)/(RHOS2(I,K)*R2(I,K)*ANN2(I,K))
     & /cat2/cfr(i,k)/xcf
      if (andor(1,k).gt.0.0) cscyle=cscyle*cfr(i,k)*xcf
      cbet2e=sqrt(1./(1.+(1./cscyle**2-1.)*cat2**2))
      BET2E(I,K)=ATAN2(SQRT(1.-CBET2E     *CBET2E     ),CBET2E     )
      GO TO 16
140   IF(RVU1(I,K).NE.0.) GO TO 15
      CBET2E     =CSBET2(I,K)
      BET2E(I,K)= BET2(I,K)
15    continue
      cscyle=sqrt(1./(1.+(1./cbet2e**2-1.)/cat2**2))
      WG2(I,K)=RHOS2(I,K)*R2(I,K)*ANN2(I,K)*Cscyle
     & *cat2*cfr(i,k)*xcf
      if (andor(1,k).gt.0.0) wg2(i,k)=wg2(i,k)/cfr(i,k)/xcf
      IF(RVU1(I,K).EQ.0.) GO TO 16
C     IF(PTRS2(I,K)-P1AS2C) 170,180,180
C     replaced by .........................
      IF((PTRS2(I,K)-P1AS2C).LT.0.) THEN
         GO TO 170
      ELSE
         GO TO 180
      ENDIF
170   CSBET2(I,K)=CBET2E
      BET2(I,K)=BET2E(I,K)
      GO TO 16
180   CScyl=WG2(I,K)/RHOS2C/R2C/ANN2(I,K)
     & /cat2/cfr(i,k)/xcf
      if (andor(1,k).gt.0.0) cscyl=cscyl*cfr(i,k)*xcf
      csbet2(i,k)=sqrt(1./(1.+(1./cscyl**2-1.)*cat2**2))
      BET2(I,K)=ATAN(SQRT(1.-CSBET2(I,K)**2)/CSBET2(I,K))*SNBET2/ASNBET
16    RU2(I,K)=R2(I,K)*SIN(BET2E(I,K))
      VU2(I,K)=RU2(I,K)-U2(I,K)
      VZ2(I,K)=R2(I,K)*CBET2E
      AS2     =SQRT(GAM(4,K)*G*rg2(k)*TS2(I,K))
      V2(I,K)=SQRT(VZ2(I,K)*VZ2(I,K)+VU2(I,K)*VU2(I,K))
      M2(I,K)=V2(I,K)/AS2
      MR2(I,K)=R2(I,K)/AS2
      MF2(I,K)=MR2(I,K)*CBET2E
      IF(I.LT.ISECT) GO TO 17
      IF(PRPC.EQ.1.) PRPC=2.
  17  j=2
      GO TO (19,21),J
19    CALL DIAGT(4)
21    RETURN
      END


!=======================================
!=======================================
! vorlaeufiges Hauptprogramm fuer Tests
! box model chemical kinetics simulation
!=======================================
!=======================================
!
!
PROGRAM AtCSol
  !
  USE Kind_Mod
  USE InitRoutines_Mod
  USE Rates_Mod
  USE Sparse_Mod
  USE Chemsys_Mod
  USE Integration_Mod
  USE Rosenbrock_Mod
  USE Control_Mod
  USE Reac_Mod
  USE MPI_Mod
  USE IO_Mod
  USE ChemKinInput_Mod
  USE NetCDF_Mod
  USE Cycles_Mod
  USE fparser
  USE ISSA_Mod
  IMPLICIT NONE
  !
  CHARACTER(80)   :: Filename0 = ''        ! *.run file
  !
  REAL(dp), ALLOCATABLE :: Atol(:)
  INTEGER  :: i,nSchwefel

  ! NetCDF stuff
  REAL(dp) :: StartTimer
  INTEGER  :: errind(1,1)
  REAL(dp), ALLOCATABLE :: ErrVals(:), Y(:)
  ! reaction rate array + part. derv. rate over temperatur vector
  REAL(dp), ALLOCATABLE :: Rate(:), DRatedT(:)  , wetRad(:)
  !
  ! use other ROS methode or tolerance
  CHARACTER(80) :: neuTolR  = ''
  CHARACTER(80) :: neuTolA  = ''
  CHARACTER(80) :: neuROW   = ''
  CHARACTER(2)  :: newLinAlg  = ''
  CHARACTER(1)  :: simul  = ''

  ! convertion from mole to mass to conc
  REAL(dp), ALLOCATABLE   :: MoleFrac(:), MassFrac(:), MoleConc(:)
  REAL(dp)                :: Press_in_dyncm2

  ! matricies for symbolic phase
  TYPE(CSR_Matrix_T)     :: Id , tmpJacCC  ! compressed row
  TYPE(SpRowColD_T)      :: temp_LU_Dec,temp_LU_Dec2    ! sparse-LU matrix format
  ! permutation vector/ pivot order for LU-decomp
  INTEGER, ALLOCATABLE :: InvPermu(:)
  INTEGER, ALLOCATABLE :: PivOrder(:)

  ! format string
  CHARACTER(14) :: fmt0 = '  [molec/cm3] '
  CHARACTER(8) ::  unit  = ''

  ! new testing stuff
  TYPE(CSR_Matrix_T) :: A_T, P_HG, S_HG, R_HG
  CHARACTER(1) :: inpt=''
  TYPE(List), ALLOCATABLE :: ReacCyc(:)
  INTEGER,    ALLOCATABLE :: Target_Spc(:)
  LOGICAL :: done=.FALSE.

  ! timer
  REAL(dp) :: t_1,t_2,h0

  LOGICAL :: more_than_one=.FALSE.

  !
  !================================================================
  !===                     MAIN Programm
  !================================================================

  !----------------------------------------------------------------
  ! ---  Initialize MPI library
  CALL StartMPI

  !----------------------------------------------------------------
  ! --- Print the program logo
  CALL Logo

  !----------------------------------------------------------------
  ! --- Read run control parameters (which runfile)
  CALL getarg( 1 , FileName0 )
  IF ( FileName0 == '' ) THEN
    WRITE(*,777,ADVANCE='NO') 'Input RUNFilename: '; READ(*,*)   FileName0
  END IF
  RunFile = TRIM(ADJUSTL(FileName0))

  !================================================================
  !===                     Initialization
  !================================================================
  !
  !----------------------------------------------------------------
  ! --- Read run-file
  CALL InitRun
  IF ( MPI_master ) WRITE(*,777) 'Initialize run-file .......... done'

  !----------------------------------------------------------------
  ! --- set cloud intervall
  LWCb = Set_pseudoLWCbounds()

  !----------------------------------------------------------------
  !  --- read the .sys data, save coefs in sparse matrix
  Time_Read = MPI_WTIME()

  IF ( MPI_master ) WRITE(*,777,ADVANCE='NO') 'Reading sys-file .............'

  IF ( ChemKin ) THEN

    CALL Read_Elements( SysFile , SysUnit )
    CALL Read_Species ( SysFile , SysUnit )
    CALL Read_Reaction( SysFile , SysUnit )

    IF ( MPI_master ) WRITE(*,*) 'done   ---->  Solve Gas Energy Equation '

   !-----------------------------------------------------------------------
   ! --- print reactions and build A, B and (B-A) structure
   !-----------------------------------------------------------------------
    CALL Print_ChemFile   ( ReactionSystem , ChemFile , ChemUnit , .TRUE. )

    CALL GetSpeciesNames( ChemFile , y_name )
    CALL Read_ThermoData( SwitchTemp , DataFile , DataUnit , nspc )

    ! set boundaries for gaseous species
    bGs(1) = 1
    bGs(2) = ns_GAS
    iGs = [(i, i=bGs(1),bGs(2))]
    hasGasSpc = .TRUE.

    !--- gather correct indices cause ChemKin mechanisms read in unsorted
    CALL Setup_ThirdBodyIndex
    CALL Setup_ReactionIndex

    !--- Read initial values
    ALLOCATE( InitValAct(ns_GAS) , InitValKat(ns_KAT) , y_emi(ns_GAS) , y_depos(ns_GAS))
    y_emi   = ZERO
    y_depos = ZERO

		!--- malloc gibbs energy, derivates
    ALLOCATE( GFE(nspc)   , DGFEdT(nspc)   &
    &       , DelGFE(neq) , DDelGFEdT(neq) )
		GFE      = ZERO; 	DGFEdT    = ZERO
		DelGFE   = ZERO; 	DDelGFEdT = ZERO

    IF ( MWFile /= '' ) THEN
      CALL Read_MolecularWeights(MW,MWFile,MWUnit,nspc)

      rMW = [ONE / MW]

      ALLOCATE( MoleFrac(ns_GAS) , MassFrac(ns_GAS) )
      MoleFrac = ZERO;	MassFrac  = ZERO

      MoleFrac = 1.0e-20_dp
      CALL Read_INI_file( InitFile , MoleFrac, InitValKat , 'GAS' , 'INITIAL' )

      !Press = Pressure0               ! initial pressure in [Pa]
      Press_in_dyncm2 = Pressure0 * Pa_to_dyncm2

      MassFrac = MoleFr_To_MassFr  ( MoleFrac )
      MoleConc = MoleFr_To_MoleConc( MoleFrac                &
      &                            , Press = Press_in_dyncm2 &
      &                            , Temp  = Temperature0    )
    ELSE
      IF (MPI_master ) THEN
        WRITE(*,*)
        WRITE(*,777) '    No molecular weights are given.  '
        WRITE(*,777) '    Make sure the initial values are given in [mole/cm3] !'
        WRITE(*,*)
      END IF
      ALLOCATE( MoleConc(ns_GAS) )
      MoleConc = 1.0e-20_dp
      CALL Read_INI_file( InitFile , MoleConc, InitValKat , 'GAS' , 'INITIAL' )
    END IF
    !CALL Read_EMISS( InitFile , y_emi )

    ! Initialising reactor density
    rho  = Density( MoleConc )
    rRho = mega/rho       ! in [cm3/g]
    InitValAct = [MoleConc , Temperature0]

  ELSE

    CALL ReadSystem( SysFile )
    IF ( MPI_master ) WRITE(*,*) 'done  ---->  Fix Temperature'

   !-----------------------------------------------------------------------
   ! --- print reactions and build A, B and (B-A) structure
   !-----------------------------------------------------------------------
    CALL Print_ChemFile( ReactionSystem , ChemFile , ChemUnit , .FALSE. )

    !-----------------------------------------------------------------------
    ! --- initialize fpraser for reactions with special rate formula
    !-----------------------------------------------------------------------
    IF ( nr_special > 0 ) THEN

      ! Initialize function parser for n special functions
      CALL initf( nr_special )

      ! Parse and bytecompile ith function string
      DO i = 1,nr_special
        CALL parsef ( i, ReactionSystem(iR%iSPECIAL(i))%Special%Formula    &
        &              , ReactionSystem(iR%iSPECIAL(i))%Special%cVariables )
      END DO
    END IF

    !-----------------------------------------------------------------------
    ! --- Input of initial data and thermodynamic properties
    CALL InputChemicalData( InitFile , DataFile , MetFile )

  END IF

  IF (MPI_ID==0) THEN
    WRITE(*,777) 'Reading ini-file ............. done'
    WRITE(*,777) 'Printing chem-file ........... done'
    WRITE(*,*)
    WRITE(*,'(10X,A,I6)') '    Number of Reactions = ', neq
    WRITE(*,'(10X,A,I6)') '    Number of Species   = ', nspc
  END IF

  !-----------------------------------------------------------------------
  ! --- Read species for diagnose (print species concs to NetCDF file)
  CALL Read_Diag( NetCDF%spc_Pos , NetCDF%spc_Phase , InitFile )
  !-----------------------------------------------------------------------

  !-----------------------------------------------------------------------
  ! --- Timers
  Time_Read   = MPI_WTIME() - Time_Read  ! Stop Input timer
  Timer_Start = MPI_WTIME()              ! Start timer for integration
  !-----------------------------------------------------------------------

  !-----------------------------------------------------------------------
  ! --- this is for the new mass action product routine
  CALL Setup_SpeciesOrder(A)
  !-----------------------------------------------------------------------

  IF (KPP_Conversion) CALL SYS_TO_KPP(ReactionSystem)

  !-----------------------------------------------------------------------
  ! --- Dimension initialisation for the unknowns and matrices
  !-----------------------------------------------------------------------
  !
  nsr = nspc + neq

  IF ( Teq ) THEN
    nDIM = nspc+1; nDIMcl = nspc+1; nDIMex = nsr+1
  ELSE
    nDIM = nspc; 	 nDIMcl = nspc;		nDIMex = nsr
  END IF

  rNspc = ONE/REAL(nspc,KIND=dp)  ! rNspc for error calculation

  ! true if mechanism contains photolytic reactions
  PHOTO = (nr_G_photo+nr_A_photo) > 0

  !----------------------------------------------------------------------------
  !--- If one wants to change the calculation of the linear systems without
  !    opening the run-file, start the simulation with a second parameter
  !----------------------------------------------------------------------------
  CALL getarg ( 2 , newLinAlg )
  IF ( newLinAlg /= '' ) THEN
    SELECT CASE (newLinAlg)
      CASE ('cl'); CLASSIC = .TRUE.;  EXTENDED = .FALSE.; LinAlg = newLinAlg
      CASE ('ex'); CLASSIC = .FALSE.; EXTENDED = .TRUE.;  LinAlg = newLinAlg
      CASE DEFAULT;  WRITE(*,777) '    Linear Algebra either "cl" or "ex" !'
    END SELECT
  END IF

  !-----------------------------------------------------------------------
  ! --- Get all sulphuric species
  !-----------------------------------------------------------------------
  ! count species
  ALLOCATE(iDiag_Schwefel(0));  nSchwefel = 0
  DO i=1,nspc
    IF ( INDEX(y_name(i),'S') > 0 ) THEN
      nSchwefel = nSchwefel + 1
      iDiag_Schwefel = [iDiag_Schwefel , PositionSpeciesAll(y_name(i))]
    END IF
  END DO

  !-----------------------------------------------------------------------
  !--- print input parameter, method, tols, concs, temp, pressure,....
  !-----------------------------------------------------------------------
  CALL Print_Run_Param

  IF (MPI_ID==0) THEN
    WRITE(*,777) 'Initial values:   '
    WRITE(*,*)

    IF ( Teq ) fmt0 = '  [mol/cm3]'
    IF ( hasGasSpc )   WRITE(*,798) 'gaseous', SUM(InitValAct( bGs(1):bGs(2) )) , fmt0
    IF ( hasAquaSpc )  WRITE(*,798) 'aqueous', SUM(InitValAct( bAs(1):bAs(2) )) , fmt0
    IF ( hasSolidSpc ) WRITE(*,798) 'solid  ', SUM(InitValAct( bSs(1):bSs(2) )) , fmt0
    IF ( hasPartiSpc ) WRITE(*,798) 'parti  ', SUM(InitValAct( bPs(1):bPs(2) )) , fmt0
    WRITE(*,800) SUM(y_emi) , '  [molec/cm3/s]'

    IF ( Teq ) THEN
      WRITE(*,801) Temperature0
      WRITE(*,802) Pressure0
      WRITE(*,803) rho
    END IF
    WRITE(*,*)
  ELSE
    ! if more than 1 process, output data only on master process
    WaitBar     = .FALSE.
    NetCdfPrint = .FALSE.
  END IF

  !-----------------------------------------------------------------------
  ! ---  Allocate arrays for some varables
  !-----------------------------------------------------------------------
	ID_1 = SparseID( nDim )
  ALLOCATE( ErrVals(nspc) , Y(nspc)   &
  &       , Rate(neq) , DRatedT(neq)  &
  &       , wetRad(nFrac)             )

	! All species get the same abs tolerance
	ALLOCATE( ATolAll(nDIM) )
	IF ( hasGasSpc )  ATolAll(iGs) = ATolGas
  IF ( hasAquaSpc ) ATolAll(iAs) = ATolAqua

	IF ( Teq ) ATolAll(nDIM) = ATolTemp

	IF ( Teq ) THEN
		Atol = [AtolGas , AtolTemp]		! abs. tolerance for ChemKin scenario
	ELSE
		Atol = [AtolGas]		! abs. tolerance for Tropos scenario
		IF ( hasAquaSpc ) Atol = [AtolGas , AtolAqua]		! abs. tolerance for Tropos scenario
  END IF

  !-----------------------------------------------------------------------
  ! --- Initialize NetCDF output file
  !-----------------------------------------------------------------------
  IF ( NetCdfPrint ) THEN
    StartTimer = MPI_WTIME()
    errind = 0
    CALL InitNetcdf
    CALL SetOutputNCDF( NetCDF, Tspan(1) , ZERO , InitValAct , Temperature0 )
    CALL StepNetCDF( NetCDF )
    TimeNetCDF = MPI_WTIME() - StartTimer
  END IF

  !-----------------------------------------------------------------------
  ! --- Symbolic phase
  !    - generating sparse matrecies of stoechiometic coefs (beta-alpha)^T
  !    - generating sparse matrecies of Jacobian matrix (if nessesarry)
  !    - generating sparse matrecies of LU decomposition of the Jacobian
  !-----------------------------------------------------------------------
  WRITE(*,777,ADVANCE='NO') 'Symbolic-phase................'
  StartTimer = MPI_WTIME()              ! start timer for symb phase

  CALL SymbolicAdd( BA , B , A )      	! symbolic addition:    BA = B + A
  CALL SparseAdd  ( BA , B , A, '-' )   ! numeric subtraction:  BA = B - A
  CALL TransposeSparse( BAT , BA )    	! transpose BA:        BAT = Transpose(BA)

  ! if either Rosenbrock method or backward Euler was choosen
  IF ( MAXVAL(INDEX(TRIM(ODEsolver(1:7)),['METHODS','bwEuler']))>0) THEN
    !---- Get Rosenbrock Parameters
    CALL SetRosenbrockMethod( ROS , ODEsolver )

    ! we need to calculate the Jacobian for both versions 'cl' and 'ex' to
    ! calculate an initial stepsize based on 2nd derivative (copy of MATLABs ode23s)
    ! symbolic mult for Jacobian Jac = [ BAT * Ones_nR * A * Ones_nS ],
    ! add diagonal entries and set them to zero
    CALL SymbolicMult( BAT , A , tmpJacCC )
    Id = SparseID( nspc )
    CALL SymbolicAdd( Jac_CC , Id , tmpJacCC )
    CALL Free_Matrix_CSR( Id )

    ALLOCATE(maxErrorCounter(nDIM))
    maxErrorCounter = 0

    ! gephi testing
    !CALL CSR_to_GephiGraph(tmpJacCC,y_name,'Test1')
    !stop ' after gephi plot'

    ! Set symbolic structure of iteration matrix for Row-Method
    ! also assign constant matrix parts like (beta-alpha)^T, alpha
    IF ( CLASSIC ) THEN
      CALL BuildSymbolicClassicMatrix(  Miter , Jac_CC  , ROS%ga )
      IF (DebugPrint) CM_1 = Copy_CSR(Jac_CC)
    ELSE !IF ( EXTENDED ) THEN
      CALL BuildSymbolicExtendedMatrix( Miter , A , BAT , ROS%ga )
    END IF

    ! Choose ordering/factorisation strategie and do symb LU fact
    IF ( useSparseLU ) THEN
      ! Permutation given by Markowitz Ordering strategie
      temp_LU_Dec = CSR_to_SpRowColD(Miter)

      !temp_LU_Dec2 = Copy_SpRowColD(temp_LU_Dec)

      IF ( Ordering == 8 ) THEN

        ! test for better permutation

        CALL SymbLU_SpRowColD_M( temp_LU_Dec )

        !IF (more_than_one) THEN
        !  DO i=1,10
        !    WRITE(*,*) ' nonzeros after fact :: ' , i , temp_LU_Dec2%nnz
        !
        !    CALL Free_SpRowColD ( temp_LU_Dec2 )
        !
        !    temp_LU_Dec2 = Copy_SpRowColD(temp_LU_Dec)
        !
        !    CALL SymbLU_SpRowColD_M ( temp_LU_Dec2 )
        !  END DO
        !END IF

        ELSE
        ALLOCATE(PivOrder(temp_LU_Dec%n))
        PivOrder = -90

        ! Pivots bis neq in reihenfolge 1,2,...,neq
        IF ( CLASSIC ) THEN
          PivOrder(     1 : nDIM     ) = [(i , i = 1     , nDim )]
        ELSE !IF ( EXTENDED ) THEN
          PivOrder(     1 : neq      ) = [(i , i = 1     , neq  )]
          PivOrder( neq+1 : neq+nDIM ) = [(i , i = neq+1 , neq+nDIM )]
        END IF
        CALL SymbLU_SpRowColD(temp_LU_Dec , PivOrder)
      END IF

      ! converting back to csr format
      LU_Miter = RowColD_to_CSR( temp_LU_Dec , nspc , neq )

      ! Get the permutation vector LU_Perm and map values of Miter
      ! to the permuted LU matrix
      CALL Get_LU_Permutaion( LU_Perm , LU_Miter , Miter , nspc , neq )

      ! For the extended case one can save the values of alpha and
      ! (beta-alpha)^T and just copy them for each iteration in ROS
      IF ( EXTENDED ) LUvalsFix = LU_Miter%Val
    END IF

    IF (MPI_ID==0) THEN

      WRITE(*,*) 'done'     ! Symbolic phase
      WRITE(*,*)

      IF (MatrixPrint) THEN
        CALL WriteSparseMatrix(A,'MATRICES/alpha_'//TRIM(BSP), neq, nspc)
        CALL WriteSparseMatrix(B,'MATRICES/beta_'//TRIM(BSP), neq, nspc)
        CALL WriteSparseMatrix(tmpJacCC,'MATRICES/JAC_'//TRIM(BSP), neq, nspc)
        CALL WriteSparseMatrix(BA,'MATRICES/BA_'//TRIM(BSP), neq, nspc)
        CALL WriteSparseMatrix(Miter,'MATRICES/Miter_'//TRIM(BSP), neq, nspc)
        CALL WriteSparseMatrix(LU_Miter,'MATRICES/LU_Miter_'//TRIM(BSP), neq, nspc)
        WRITE(*,777,ADVANCE='NO') '  Continue? [y/n]';  READ(*,*) inpt
        IF (inpt/='y') STOP
      END IF

      WRITE(*,777) 'Matrix Statistics: '
      WRITE(*,*)
      CALL Matrix_Statistics(A,B,BA,BAT,S_HG,tmpJacCC,Miter,LU_Miter)
    END IF

    CALL Free_Matrix_CSR( A_T )
    CALL Free_Matrix_CSR( P_HG )
    CALL Free_Matrix_CSR( S_HG )
    CALL Free_Matrix_CSR( R_HG )
    CALL Free_Matrix_CSR( tmpJacCC )
    CALL Free_SpRowColD( temp_LU_Dec )

    TimeSymbolic = MPI_WTIME() - StartTimer   ! stop timer for symbolic matrix calculations
    ! ---- Calculate first reaction rates
    RateCnt = 0
    IF (Teq) THEN
      CALL ReactionRates( Tspan(1) , [InitValAct,Temperature0] , Rate , DRatedT )
    ELSE
      CALL ReactionRates( Tspan(1) , InitValAct , Rate )
    END IF
    Y = MAX( ABS(InitValAct) , eps ) * SIGN( ONE , InitValAct )    ! |y| >= eps

    ! ---- Calculate values of Jacobian
    StartTimer = MPI_WTIME()
    CALL Jacobian_CC( Jac_CC , BAT , A , Rate , Y )
    Out%npds = Out%npds + 1
    TimeJac  = TimeJac + MPI_WTIME() - StartTimer
  END IF

  !WRITE(*,777,ADVANCE='NO') 'Simulation? [y/n]   ';  READ(*,*) simul
  IF ( Simulation ) THEN
    ! open file to save the fluxes
    IF ( MPI_master .AND. FluxDataPrint ) THEN
      iStpFlux = 0
      FluxFile     = 'REDUCTION/flux_'//TRIM(BSP)//'.dat'
      FluxMetaFile = 'REDUCTION/fluxmeta_'//TRIM(BSP)//'.dat'
      CALL OpenFile_wStream(FluxUnit,FluxFile);       CLOSE(FluxUnit)
      CALL OpenFile_wSeq(FluxMetaUnit,FluxMetaFile);  CLOSE(FluxMetaUnit)
    END IF

    !-----------------------------------------------------------------------
    ! --- Start the integration routine
    !-----------------------------------------------------------------------
    IF ( StpNetCDF < ZERO ) THEN
      Tspan = [tBegin, tEnd]
    ELSE
      Tspan = [tBegin, StpNetCDF]
    END IF

    !---- Calculate a first stepsize based on 2nd deriv.
    h0 = InitialStepSize( Jac_CC, Rate, Tspan(1), InitValAct, ROS%pow )

    ! --- same output as KPP
    OPEN( unit=999,       file='SpcConc.AtCSol',      status='replace', &
      &     action='write', access='sequential')
      WRITE(999,*) ' T             ',( TRIM(Diag_Name(i))//'            ', i=1,SIZE(Diag_Name) )
      WRITE(999,*) ' T(idx)  ',( i,' ', i=1,SIZE(Diag_Name) )

    DO
      !WRITE(999,'(*(Es14.6))') Tspan(1), ( InitValAct(Diag_Index(i)), i=1,SIZE(Diag_Index) )
      CALL Integrate ( InitValAct   &  ! initial concentrations activ species
      &              , Temperature0 &  ! initial temperature
      &              , h0           &  ! reaction rates at time=t0
      &              , Tspan        &  ! integration invervall
      &              , Atol         &  ! abs. tolerance of species
      &              , RtolROW      &  ! rel. tolerance Rosenbrock method
      &              , ODEsolver    )  ! methode for solving the ode system

      IF (Tspan(2) == tEnd .OR. done) EXIT
      Tspan = [Tspan(2), Tspan(2)+StpNetCDF]

      ! --- Hit end point exactly.
      IF ( Tspan(2) >= tEnd ) THEN
        TSpan(2) = tEnd
        done = .TRUE.
      END IF

    END DO

    WRITE(999,'(*(Es14.6))')  tEnd, ( InitValAct(Diag_Index(i)), i=1,SIZE(Diag_Index) )
    CLOSE(999)

    ! --- stop timer and print output statistics
    Timer_Finish = MPI_WTIME() - Timer_Start + Time_Read

    CALL Output_Statistics

    IF (NetCdfPrint) CALL TikZ_finished

  END IF

  IF ( MPI_master .AND. Reduction ) THEN
    !-----------------------------------------------------------------------
    ! --- Start the reduction procedure
    !-----------------------------------------------------------------------
    CALL Logo2

    !-----------------------------------------------------------------------
    ! --- Read species groups in order to combine them (Species Lumping)
    StartTimer = MPI_WTIME()

    CALL InitReduction
    WRITE(*,*)
    WRITE(*,*) TRIM(TargetFile)
    WRITE(*,*) TRIM(FluxFile)
    WRITE(*,*) TRIM(FluxMetaFile)

    CALL ISSA_structure( ReacCyc , Target_Spc , TargetFile )
    CALL ISSA_screening( ReactionSystem, ReacCyc, Target_Spc )

    TimeReduction = MPI_WTIME()-StartTimer

    CALL ConvertTime(TimeReduction,unit)
    WRITE(*,'(32X,A,1X,F10.4,A)') 'Time ISSA reduction = ', TimeReduction, unit
    WRITE(*,*);

  END IF

  ! --- Close MPI
  IF ( MPI_master ) THEN
    WRITE(*,*); WRITE(*,*)
  END IF

  CALL ShowMaxErrorCounter()

  CALL FinishMPI()

  !================================================================
  !==  FORMAT Statements
  !================================================================
  !
  777  FORMAT(10X,A)
  798  FORMAT(10X,'    Sum Initval (',A7,')      =  ', Es8.2, A)
  800  FORMAT(10X,'    Sum Emissions (gaseous)    =  ', Es8.2, A)
  801  FORMAT(10X,'    Temperature                =  ', Es8.2,'  [K]')
  802  FORMAT(10X,'    Pressure                   =  ', Es8.2,'  [Pa]')
  803  FORMAT(10X,'    Reactor denstiy            =  ', Es8.2,'  [kg/cm3]')
END PROGRAM AtCSol


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine korbit  --  pisystem parameter assignment  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "korbit" assigns pi-orbital parameters to conjugated
c     systems and processes any new or changed parameters
c
c
      subroutine korbit
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'korbs.i'
      include 'orbits.i'
      include 'piorbs.i'
      include 'pistuf.i'
      include 'tors.i'
      include 'units.i'
      integer i,j,k,jt
      integer ia,ib,ita,itb
      integer npi,npi5,npi4
      integer size,next,iring
      real*8 elect,ioniz
      real*8 repuls
      real*8 sslop,tslop
      logical header
      logical use_ring
      character*4 pa,pb
      character*6 label
      character*8 blank,pt
      character*20 keyword
      character*120 record
      character*120 string
c
c
c     process keywords containing pisystem atom parameters
c
      blank = '        '
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'PIATOM ') then
            ia = 0
            elect = 0.0d0
            ioniz = 0.0d0
            repuls = 0.0d0
            string = record(next:120)
            read (string,*,err=10)  ia,elect,ioniz,repuls
   10       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Pisystem Atom Parameters :',
     &                    //,6x,'Atom Type',3x,'Electron',
     &                       3x,'Ionization',3x,'Repulsion',/)
               end if
               write (iout,30)  ia,elect,ioniz,repuls
   30          format (8x,i4,3x,f10.3,3x,f10.3,2x,f10.3)
            end if
            if (ia.gt.0 .and. ia.le.maxclass) then
               electron(ia) = elect
               ionize(ia) = ioniz
               repulse(ia) = repuls
            else
   40          format (/,' KORBIT  --  Too many Atom Classes;',
     &                    ' Increase MAXCLASS')
               abort = .true.
            end if
         end if
      end do
c
c     process keywords containing pisystem bond parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         iring = -1
         if (keyword(1:7) .eq. 'PIBOND ')  iring = 0
         if (keyword(1:8) .eq. 'PIBOND5 ')  iring = 5
         if (keyword(1:8) .eq. 'PIBOND4 ')  iring = 4
         if (iring .ge. 0) then
            ia = 0
            ib = 0
            sslop = 0.0d0
            tslop = 0.0d0
            string = record(next:120)
            read (string,*,err=50)  ia,ib,sslop,tslop
   50       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,60)
   60             format (/,' Additional Pisystem Bond Parameters :',
     &                    //,6x,'Atom Types',7x,'d Force',4x,
     &                       'd Length',/)
               end if
               if (iring .eq. 0) then
                  write (iout,70)  ia,ib,sslop,tslop
   70             format (6x,2i4,5x,2f11.3)
               else
                  if (iring .eq. 5)  label = '5-Ring'
                  if (iring .eq. 4)  label = '4-Ring'
                  write (iout,80)  ia,ib,sslop,tslop,label
   80             format (6x,2i4,5x,2f11.3,3x,a6)
               end if
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            if (iring .eq. 0) then
               do j = 1, maxnpi
                  if (kpi(j).eq.blank .or. kpi(j).eq.pt) then
                     kpi(j) = pt
                     sslope(j) = sslop
                     tslope(j) = tslop
                     goto 100
                  end if
               end do
               write (iout,90)
   90          format (/,' KORBIT  --  Too many Pisystem Bond',
     &                    ' Type Parameters')
               abort = .true.
  100          continue
            else if (iring .eq. 5) then
               do j = 1, maxnpi5
                  if (kpi5(j).eq.blank .or. kpi5(j).eq.pt) then
                     kpi5(j) = pt
                     sslope5(j) = sslop
                     tslope5(j) = tslop
                     goto 120
                  end if
               end do
               write (iout,110)
  110          format (/,' KORBIT  --  Too many 5-Ring Pisystem Bond',
     &                    ' Type Parameters')
               abort = .true.
  120          continue
            else if (iring .eq. 4) then
               do j = 1, maxnpi4
                  if (kpi4(j).eq.blank .or. kpi4(j).eq.pt) then
                     kpi4(j) = pt
                     sslope4(j) = sslop
                     tslope4(j) = tslop
                     goto 140
                  end if
               end do
               write (iout,130)
  130          format (/,' KORBIT  --  Too many 4-Ring Pisystem Bond',
     &                    ' Type Parameters')
               abort = .true.
  140          continue
            end if
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      npi = maxnpi
      npi5 = maxnpi5
      npi4 = maxnpi4
      do i = maxnpi, 1, -1
         if (kpi(i) .eq. blank)  npi = i - 1
      end do
      do i = maxnpi5, 1, -1
         if (kpi5(i) .eq. blank)  npi5 = i - 1
      end do
      do i = maxnpi4, 1, -1
         if (kpi4(i) .eq. blank)  npi4 = i - 1
      end do
      use_ring = .false.
      if (min(npi5,npi4) .ne. 0)  use_ring = .true.
c
c     assign the values characteristic of the piatom types
c
      do i = 1, norbit
         j = iorbit(i)
         jt = type(j)
         q(j) = electron(jt)
         w(j) = ionize(jt) / evolt
         em(j) = repulse(jt) / evolt
      end do
c
c     assign parameters for all bonds between piatoms;
c     store the original bond lengths and force constants
c
      do i = 1, nbpi
         j = ibpi(1,i)
         ia = iorbit(ibpi(2,i))
         ib = iorbit(ibpi(3,i))
         ita = class(ia)
         itb = class(ib)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pt = pa//pb
         else
            pt = pb//pa
         end if
c
c     make a check for bonds contained inside small rings
c
         iring = 0
         if (use_ring) then
            call chkring (iring,ia,ib,0,0)
            if (iring .eq. 6)  iring = 0
            if (iring.eq.5 .and. npi5.eq.0)  iring = 0
            if (iring.eq.4 .and. npi4.eq.0)  iring = 0
            if (iring .eq. 3)  iring = 0
         end if
c
c     assign conjugated bond parameters for each pibond
c
         if (iring .eq. 0) then
            do k = 1, npi
               if (kpi(k) .eq. pt) then
                  bkpi(j) = bk(j)
                  blpi(j) = bl(j)
                  kslope(j) = sslope(k)
                  lslope(j) = tslope(k)
                  goto 170
               end if
            end do
c
c     assign bond parameters for 5-membered ring pibonds
c
         else if (iring .eq. 5) then
            do k = 1, npi5
               if (kpi5(k) .eq. pt) then
                  bkpi(j) = bk(j)
                  blpi(j) = bl(j)
                  kslope(j) = sslope5(k)
                  lslope(j) = tslope5(k)
                  goto 170
               end if
            end do
c
c     assign bond parameters for 4-membered ring pibonds
c
         else if (iring .eq. 4) then
            do k = 1, npi4
               if (kpi4(k) .eq. pt) then
                  bkpi(j) = bk(j)
                  blpi(j) = bl(j)
                  kslope(j) = sslope4(k)
                  lslope(j) = tslope4(k)
                  goto 170
               end if
            end do
         end if
c
c     warning if suitable conjugated pibond parameters not found
c
         abort = .true.
         if (header) then
            header = .false.
            write (iout,150)
  150       format (/,' Undefined Conjugated Pibond Parameters :',
     &              //,' Type',13x,'Atom Names',11x,
     &                 'Atom Classes',/)
         end if
         label = 'Pibond'
         if (iring .eq. 5)  label = '5-Ring'
         if (iring .eq. 4)  label = '4-Ring'
         write (iout,160)  label,ia,name(ia),ib,name(ib),ita,itb
  160    format (1x,a6,5x,i6,'-',a3,i6,'-',a3,7x,2i5)
  170    continue
      end do
c
c     store original 2-fold torsional constants across pibonds
c
      do i = 1, ntors
         torsp2(i) = tors2(1,i)
      end do
      return
      end