      SUBROUTINE INTEGRATE( TIN, TOUT )

      IMPLICIT NONE
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'
      INTEGER Nstp, Nacc, Nrej, Nsng, IERR
      SAVE Nstp, Nacc, Nrej, Nsng

! TIN - Start Time
      KPP_REAL TIN
! TOUT - End Time
      KPP_REAL TOUT
      INTEGER i

      KPP_REAL  RPAR(20)
      INTEGER  IPAR(20)
      EXTERNAL  FunTemplate, JacTemplate

      DO i=1,20
        IPAR(i) = 0
        RPAR(i) = 0.0d0
      ENDDO

      IPAR(1) = 0       ! non-autonomous
      IPAR(2) = 1       ! vector tolerances
      RPAR(3) = STEPMIN ! starting step
      IPAR(4) = 5       ! choice of the method

      CALL Rosenbrock(VAR,TIN,TOUT,
     &            ATOL,RTOL,
     &            FunTemplate,JacTemplate,
     &            RPAR,IPAR,IERR)

      Nstp = Nstp + IPAR(13)
      Nacc = Nacc + IPAR(14)
      Nrej = Nrej + IPAR(15)
      Nsng = Nsng + IPAR(18)
      PRINT*,'Step=',Nstp,' Acc=',Nacc,' Rej=',Nrej,
     &      ' Singular=',Nsng

      IF (IERR.LT.0) THEN
        print *,'Rosenbrock: Unsucessful step at T=',
     &          TIN,' (IERR=',IERR,')'
      ENDIF

      TIN = RPAR(11) ! Exit time
      STEPMIN = RPAR(12)

      RETURN
      END

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE Rosenbrock(Y,Tstart,Tend,
     &            AbsTol,RelTol,
     &            ode_Fun,ode_Jac ,
     &            RPAR,IPAR,IERR)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!    Solves the system y'=F(t,y) using a Rosenbrock method defined by:
!
!     G = 1/(H*gamma(1)) - ode_Jac(t0,Y0)
!     T_i = t0 + Alpha(i)*H
!     Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j
!     G * K_i = ode_Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j +
!                  gamma(i)*dF/dT(t0, Y0)
!     Y1 = Y0 + \sum_{j=1}^S M(j)*K_j
!
!    For details on Rosenbrock methods and their implementation consult:
!         E. Hairer and G. Wanner
!         "Solving ODEs II. Stiff and differential-algebraic problems".
!         Springer series in computational mathematics, Springer-Verlag, 1996.
!    The codes contained in the book inspired this implementation.
!
!    (C)  Adrian Sandu, August 2004
!    Virginia Polytechnic Institute and State University
!    Contact: sandu@cs.vt.edu
!    This implementation is part of KPP - the Kinetic PreProcessor
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~>      INPUT ARGUMENTS:
!
!-     Y(NVAR)       = vector of initial conditions (at T=Tstart)
!-    [Tstart,Tend]  = time range of integration
!        (if Tstart>Tend the integration is performed backwards in time)
!-    RelTol, AbsTol = user precribed accuracy
!-    SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function,
!                                         returns Ydot = Y' = F(T,Y)
!-    SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function,
!                                         returns Jcb = dF/dY
!-    IPAR(1:10)    = integer inputs parameters
!-    RPAR(1:10)    = real inputs parameters
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~>     OUTPUT ARGUMENTS:
!
!-    Y(NVAR)       -> vector of final states (at T->Tend)
!-    IPAR(11:20)   -> integer output parameters
!-    RPAR(11:20)   -> real output parameters
!-    IERR          -> job status upon return
!          - succes (positive value) or failure (negative value) -
!                    =  1 : Success
!                    = -1 : Improper value for maximal no of steps
!                    = -2 : Selected Rosenbrock method not implemented
!                    = -3 : Hmin/Hmax/Hstart must be positive
!                    = -4 : FacMin/FacMax/FacRej must be positive
!                    = -5 : Improper tolerance values
!                    = -6 : No of steps exceeds maximum bound
!                    = -7 : Step size too small
!                    = -8 : Matrix is repeatedly singular
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~>     INPUT PARAMETERS:
!
!    Note: For input parameters equal to zero the default values of the
!          corresponding variables are used.
!
!    IPAR(1)   = 1: F = F(y)   Independent of T (AUTONOMOUS)
!              = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS)
!    IPAR(2)   = 0: AbsTol, RelTol are NVAR-dimensional vectors
!              = 1:  AbsTol, RelTol are scalars
!    IPAR(3)  -> maximum number of integration steps
!              For IPAR(3)=0) the default value of 100000 is used
!
!    IPAR(4)  -> selection of a particular Rosenbrock method
!              = 0 :  default method is Rodas3
!              = 1 :  method is  Ros2
!              = 2 :  method is  Ros3
!              = 3 :  method is  Ros4
!              = 4 :  method is  Rodas3
!              = 5:   method is  Rodas4
!
!    RPAR(1)  -> Hmin, lower bound for the integration step size
!                It is strongly recommended to keep Hmin = ZERO
!    RPAR(2)  -> Hmax, upper bound for the integration step size
!    RPAR(3)  -> Hstart, starting value for the integration step size
!
!    RPAR(4)  -> FacMin, lower bound on step decrease factor (default=0.2)
!    RPAR(5)  -> FacMin,upper bound on step increase factor (default=6)
!    RPAR(6)  -> FacRej, step decrease factor after multiple rejections
!                        (default=0.1)
!    RPAR(7)  -> FacSafe, by which the new step is slightly smaller
!                  than the predicted value  (default=0.9)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~>     OUTPUT PARAMETERS:
!
!    Note: each call to Rosenbrock adds the corrent no. of fcn calls
!         to previous value of IPAR(11), and similar for the other params.
!         Set IPAR(11:20) = 0 before call to avoid this accumulation.
!
!    IPAR(11) = No. of function calls
!    IPAR(12) = No. of jacobian calls
!    IPAR(13) = No. of steps
!    IPAR(14) = No. of accepted steps
!    IPAR(15) = No. of rejected steps (except at the beginning)
!    IPAR(16) = No. of LU decompositions
!    IPAR(17) = No. of forward/backward substitutions
!    IPAR(18) = No. of singular matrix decompositions
!
!    RPAR(11)  -> Texit, the time corresponding to the
!                        computed Y upon return
!    RPAR(12)  -> Hexit, last accepted step before exit
!    For multiple restarts, use Hexit as Hstart in the following run
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      IMPLICIT NONE
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Sparse.h'

      KPP_REAL Tstart,Tend
      KPP_REAL Y(KPP_NVAR),AbsTol(KPP_NVAR),RelTol(KPP_NVAR)
      INTEGER IPAR(20)
      KPP_REAL RPAR(20)
      INTEGER IERR
!~~~>  The method parameters
      INTEGER Smax
      PARAMETER (Smax = 6)
      INTEGER  Method, ros_S
      KPP_REAL ros_M(Smax), ros_E(Smax)
      KPP_REAL ros_A(Smax*(Smax-1)/2), ros_C(Smax*(Smax-1)/2)
      KPP_REAL ros_Alpha(Smax), ros_Gamma(Smax), ros_ELO
      LOGICAL  ros_NewF(Smax)
      CHARACTER*12 ros_Name
!~~~>  Local variables
      KPP_REAL Roundoff,FacMin,FacMax,FacRej,FacSafe
      KPP_REAL Hmin, Hmax, Hstart, Hexit
      KPP_REAL Texit
      INTEGER i, UplimTol, Max_no_steps
      LOGICAL Autonomous, VectorTol
!~~~>   Statistics on the work performed
      INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng
      COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej,
     &       Ndec,Nsol,Nsng
!~~~>   Parameters
      KPP_REAL ZERO, ONE, DeltaMin
      PARAMETER (ZERO = 0.0d0)
      PARAMETER (ONE  = 1.0d0)
      PARAMETER (DeltaMin = 1.0d-5)
!~~~>   Functions
      EXTERNAL ode_Fun, ode_Jac
      KPP_REAL WLAMCH, ros_ErrorNorm
      EXTERNAL WLAMCH, ros_ErrorNorm

!~~~>  Initialize statistics
      Nfun = IPAR(11)
      Njac = IPAR(12)
      Nstp = IPAR(13)
      Nacc = IPAR(14)
      Nrej = IPAR(15)
      Ndec = IPAR(16)
      Nsol = IPAR(17)
      Nsng = IPAR(18)

!~~~>  Autonomous or time dependent ODE. Default is time dependent.
      Autonomous = .NOT.(IPAR(1).EQ.0)

!~~~>  For Scalar tolerances (IPAR(2).NE.0)  the code uses AbsTol(1) and RelTol(1)
!      For Vector tolerances (IPAR(2).EQ.0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR)
      IF (IPAR(2).EQ.0) THEN
         VectorTol = .TRUE.
	 UplimTol  = KPP_NVAR
      ELSE
         VectorTol = .FALSE.
	 UplimTol  = 1
      END IF

!~~~>   The maximum number of steps admitted
      IF (IPAR(3).EQ.0) THEN
         Max_no_steps = 100000
      ELSEIF (Max_no_steps.GT.0) THEN
         Max_no_steps=IPAR(3)
      ELSE
         WRITE(6,*)'User-selected max no. of steps: IPAR(3)=',IPAR(3)
         CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR)
	 RETURN
      END IF

!~~~>  The particular Rosenbrock method chosen
      IF (IPAR(4).EQ.0) THEN
         Method = 3
      ELSEIF ( (IPAR(4).GE.1).AND.(IPAR(4).LE.5) ) THEN
         Method = IPAR(4)
      ELSE
         WRITE (6,*) 'User-selected Rosenbrock method: IPAR(4)=', Method
         CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR)
	 RETURN
      END IF

!~~~>  Unit roundoff (1+Roundoff>1)
      Roundoff = WLAMCH('E')

!~~~>  Lower bound on the step size: (positive value)
      IF (RPAR(1).EQ.ZERO) THEN
         Hmin = ZERO
      ELSEIF (RPAR(1).GT.ZERO) THEN
         Hmin = RPAR(1)
      ELSE
         WRITE (6,*) 'User-selected Hmin: RPAR(1)=', RPAR(1)
         CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR)
	 RETURN
      END IF
!~~~>  Upper bound on the step size: (positive value)
      IF (RPAR(2).EQ.ZERO) THEN
         Hmax = ABS(Tend-Tstart)
      ELSEIF (RPAR(2).GT.ZERO) THEN
         Hmax = MIN(ABS(RPAR(2)),ABS(Tend-Tstart))
      ELSE
         WRITE (6,*) 'User-selected Hmax: RPAR(2)=', RPAR(2)
         CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR)
	 RETURN
      END IF
!~~~>  Starting step size: (positive value)
      IF (RPAR(3).EQ.ZERO) THEN
         Hstart = MAX(Hmin,DeltaMin)
      ELSEIF (RPAR(3).GT.ZERO) THEN
         Hstart = MIN(ABS(RPAR(3)),ABS(Tend-Tstart))
      ELSE
         WRITE (6,*) 'User-selected Hstart: RPAR(3)=', RPAR(3)
         CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR)
	 RETURN
      END IF
!~~~>  Step size can be changed s.t.  FacMin < Hnew/Hexit < FacMax
      IF (RPAR(4).EQ.ZERO) THEN
         FacMin = 0.2d0
      ELSEIF (RPAR(4).GT.ZERO) THEN
         FacMin = RPAR(4)
      ELSE
         WRITE (6,*) 'User-selected FacMin: RPAR(4)=', RPAR(4)
         CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR)
	 RETURN
      END IF
      IF (RPAR(5).EQ.ZERO) THEN
         FacMax = 6.0d0
      ELSEIF (RPAR(5).GT.ZERO) THEN
         FacMax = RPAR(5)
      ELSE
         WRITE (6,*) 'User-selected FacMax: RPAR(5)=', RPAR(5)
         CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR)
	 RETURN
      END IF
!~~~>   FacRej: Factor to decrease step after 2 succesive rejections
      IF (RPAR(6).EQ.ZERO) THEN
         FacRej = 0.1d0
      ELSEIF (RPAR(6).GT.ZERO) THEN
         FacRej = RPAR(6)
      ELSE
         WRITE (6,*) 'User-selected FacRej: RPAR(6)=', RPAR(6)
         CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR)
	 RETURN
      END IF
!~~~>   FacSafe: Safety Factor in the computation of new step size
      IF (RPAR(7).EQ.ZERO) THEN
         FacSafe = 0.9d0
      ELSEIF (RPAR(7).GT.ZERO) THEN
         FacSafe = RPAR(7)
      ELSE
         WRITE (6,*) 'User-selected FacSafe: RPAR(7)=', RPAR(7)
         CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR)
	 RETURN
      END IF
!~~~>  Check if tolerances are reasonable
       DO i=1,UplimTol
         IF ( (AbsTol(i).LE.ZERO) .OR. (RelTol(i).LE.10.d0*Roundoff)
     &          .OR. (RelTol(i).GE.1.0d0) ) THEN
            WRITE (6,*) ' AbsTol(',i,') = ',AbsTol(i)
            WRITE (6,*) ' RelTol(',i,') = ',RelTol(i)
            CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR)
	    RETURN
         END IF
       END DO

!~~~>   Initialize the particular Rosenbrock method

      IF (Method .EQ. 1) THEN
         CALL Ros2(ros_S, ros_A, ros_C, ros_M, ros_E,
     &             ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name)
      ELSEIF (Method .EQ. 2) THEN
         CALL Ros3(ros_S, ros_A, ros_C, ros_M, ros_E,
     &             ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name)
      ELSEIF (Method .EQ. 3) THEN
         CALL Ros4(ros_S, ros_A, ros_C, ros_M, ros_E,
     &             ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name)
      ELSEIF (Method .EQ. 4) THEN
         CALL Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E,
     &             ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name)
      ELSEIF (Method .EQ. 5) THEN
         CALL Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E,
     &             ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name)
      ELSE
         WRITE (6,*) 'Unknown Rosenbrock method: IPAR(4)=', Method
         CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR)
	 RETURN
      END IF

!~~~>  CALL Rosenbrock method
      CALL RosenbrockIntegrator(Y,Tstart,Tend,Texit,
     &      AbsTol,RelTol,
     &      ode_Fun,ode_Jac ,
!  Rosenbrock method coefficients
     &      ros_S, ros_M, ros_E, ros_A, ros_C,
     &      ros_Alpha, ros_Gamma, ros_ELO, ros_NewF,
!  Integration parameters
     &      Autonomous, VectorTol, Max_no_steps,
     &      Roundoff, Hmin, Hmax, Hstart, Hexit,
     &      FacMin, FacMax, FacRej, FacSafe,
!  Error indicator
     &      IERR)

!~~~>  Collect run statistics
      IPAR(11) = Nfun
      IPAR(12) = Njac
      IPAR(13) = Nstp
      IPAR(14) = Nacc
      IPAR(15) = Nrej
      IPAR(16) = Ndec
      IPAR(17) = Nsol
      IPAR(18) = Nsng
!~~~> Last T and H
      RPAR(11) = Texit
      RPAR(12) = Hexit

      RETURN
      END  !  SUBROUTINE Rosenbrock

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE RosenbrockIntegrator(Y,Tstart,Tend,T,
     &      AbsTol,RelTol,
     &      ode_Fun,ode_Jac ,
!~~~> Rosenbrock method coefficients
     &      ros_S, ros_M, ros_E, ros_A, ros_C,
     &      ros_Alpha, ros_Gamma, ros_ELO, ros_NewF,
!~~~> Integration parameters
     &      Autonomous, VectorTol, Max_no_steps,
     &      Roundoff, Hmin, Hmax, Hstart, Hexit,
     &      FacMin, FacMax, FacRej, FacSafe,
!~~~> Error indicator
     &      IERR)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!   Template for the implementation of a generic Rosenbrock method
!            defined by ros_S (no of stages)
!            and its coefficients ros_{A,C,M,E,Alpha,Gamma}
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      IMPLICIT NONE
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Sparse.h'

!~~~> Input: the initial condition at Tstart; Output: the solution at T
      KPP_REAL Y(KPP_NVAR)
!~~~> Input: integration interval
      KPP_REAL Tstart,Tend
!~~~> Output: time at which the solution is returned (T=Tend if success)
      KPP_REAL T
!~~~> Input: tolerances
      KPP_REAL  AbsTol(KPP_NVAR), RelTol(KPP_NVAR)
!~~~> Input: ode function and its Jacobian
      EXTERNAL ode_Fun, ode_Jac
!~~~> Input: The Rosenbrock method parameters
      INTEGER  ros_S
      KPP_REAL ros_M(ros_S), ros_E(ros_S)
      KPP_REAL ros_A(ros_S*(ros_S-1)/2), ros_C(ros_S*(ros_S-1)/2)
      KPP_REAL ros_Alpha(ros_S), ros_Gamma(ros_S), ros_ELO
      LOGICAL ros_NewF(ros_S)
!~~~> Input: integration parameters
      LOGICAL Autonomous, VectorTol
      KPP_REAL Hstart, Hmin, Hmax
      INTEGER Max_no_steps
      KPP_REAL Roundoff, FacMin, FacMax, FacRej, FacSafe
!~~~> Output: last accepted step
      KPP_REAL Hexit
!~~~> Output: Error indicator
      INTEGER IERR
! ~~~~ Local variables
      KPP_REAL Ynew(KPP_NVAR), Fcn0(KPP_NVAR), Fcn(KPP_NVAR),
     &       K(KPP_NVAR*ros_S), dFdT(KPP_NVAR),
     &       Jac0(KPP_LU_NONZERO), Ghimj(KPP_LU_NONZERO)
      KPP_REAL H, Hnew, HC, HG, Fac, Tau
      KPP_REAL Err, Yerr(KPP_NVAR)
      INTEGER Pivot(KPP_NVAR), Direction, ioffset, j, istage
      LOGICAL RejectLastH, RejectMoreH, Singular
!~~~>  Local parameters
      KPP_REAL ZERO, ONE, DeltaMin
      PARAMETER (ZERO = 0.0d0)
      PARAMETER (ONE  = 1.0d0)
      PARAMETER (DeltaMin = 1.0d-5)
!~~~>  Locally called functions
      KPP_REAL WLAMCH, ros_ErrorNorm
      EXTERNAL WLAMCH, ros_ErrorNorm
!~~~>  Statistics on the work performed
      INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng
      COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej,
     &       Ndec,Nsol,Nsng
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!~~~>  INITIAL PREPARATIONS
      T = Tstart
      Hexit = 0.0d0
      H = MIN(Hstart,Hmax)
      IF (ABS(H).LE.10.d0*Roundoff) THEN
           H = DeltaMin
      END IF

      IF (Tend .GE. Tstart) THEN
        Direction = +1
      ELSE
        Direction = -1
      END IF

      RejectLastH=.FALSE.
      RejectMoreH=.FALSE.

!~~~> Time loop begins below

      DO WHILE ( (Direction.GT.0).AND.((T-Tend)+Roundoff.LE.ZERO)
     &     .OR. (Direction.LT.0).AND.((Tend-T)+Roundoff.LE.ZERO) )

      IF ( Nstp.GT.Max_no_steps ) THEN  ! Too many steps
	CALL ros_ErrorMsg(-6,T,H,IERR)
	RETURN
      END IF
      IF ( ((T+0.1d0*H).EQ.T).OR.(H.LE.Roundoff) ) THEN  ! Step size too small
	CALL ros_ErrorMsg(-7,T,H,IERR)
	RETURN
      END IF

!~~~>  Limit H if necessary to avoid going beyond Tend
      Hexit = H
      H = MIN(H,ABS(Tend-T))

!~~~>   Compute the function at current time
      CALL ode_Fun(T,Y,Fcn0)

!~~~>  Compute the function derivative with respect to T
      IF (.NOT.Autonomous) THEN
         CALL ros_FunTimeDerivative ( T, Roundoff, Y,
     &                       Fcn0, ode_Fun, dFdT )
      END IF

!~~~>   Compute the Jacobian at current time
      CALL ode_Jac(T,Y,Jac0)

!~~~>  Repeat step calculation until current step accepted
      DO WHILE (.TRUE.) ! WHILE STEP NOT ACCEPTED

      CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1),
     &              Jac0,Ghimj,Pivot,Singular)
      IF (Singular) THEN ! More than 5 consecutive failed decompositions
	 CALL ros_ErrorMsg(-8,T,H,IERR)
	 RETURN
      END IF

!~~~>   Compute the stages
      DO istage = 1, ros_S

	 ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+KPP_NVAR)
	 ioffset = KPP_NVAR*(istage-1)

	 ! For the 1st istage the function has been computed previously
	 IF ( istage.EQ.1 ) THEN
	   CALL WCOPY(KPP_NVAR,Fcn0,1,Fcn,1)
	 ! istage>1 and a new function evaluation is needed at the current istage
	 ELSEIF ( ros_NewF(istage) ) THEN
	   CALL WCOPY(KPP_NVAR,Y,1,Ynew,1)
	   DO j = 1, istage-1
	     CALL WAXPY(KPP_NVAR,ros_A((istage-1)*(istage-2)/2+j),
     &                   K(KPP_NVAR*(j-1)+1),1,Ynew,1)
	   END DO
	   Tau = T + ros_Alpha(istage)*Direction*H
           CALL ode_Fun(Tau,Ynew,Fcn)
	 END IF ! if istage.EQ.1 elseif ros_NewF(istage)
	 CALL WCOPY(KPP_NVAR,Fcn,1,K(ioffset+1),1)
	 DO j = 1, istage-1
	   HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H)
	   CALL WAXPY(KPP_NVAR,HC,K(KPP_NVAR*(j-1)+1),1,K(ioffset+1),1)
	 END DO
         IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN
           HG = Direction*H*ros_Gamma(istage)
	   CALL WAXPY(KPP_NVAR,HG,dFdT,1,K(ioffset+1),1)
         END IF
         CALL SolveTemplate(Ghimj, Pivot, K(ioffset+1))

      END DO  ! istage

!~~~>  Compute the new solution
      CALL WCOPY(KPP_NVAR,Y,1,Ynew,1)
      DO j=1,ros_S
	 CALL WAXPY(KPP_NVAR,ros_M(j),K(KPP_NVAR*(j-1)+1),1,Ynew,1)
      END DO

!~~~>  Compute the error estimation
      CALL WSCAL(KPP_NVAR,ZERO,Yerr,1)
      DO j=1,ros_S
	CALL WAXPY(KPP_NVAR,ros_E(j),K(KPP_NVAR*(j-1)+1),1,Yerr,1)
      END DO
      Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol )

!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax
      Fac  = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO)))
      Hnew = H*Fac

!~~~>  Check the error magnitude and adjust step size
      Nstp = Nstp+1
      IF ( (Err.LE.ONE).OR.(H.LE.Hmin) ) THEN  !~~~> Accept step
         Nacc = Nacc+1
	 CALL WCOPY(KPP_NVAR,Ynew,1,Y,1)
         T = T + Direction*H
	 Hnew = MAX(Hmin,MIN(Hnew,Hmax))
         IF (RejectLastH) THEN  ! No step size increase after a rejected step
	    Hnew = MIN(Hnew,H)
	 END IF
         RejectLastH = .FALSE.
         RejectMoreH = .FALSE.
         H = Hnew
	 GOTO 101  ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED
      ELSE                 !~~~> Reject step
         IF (RejectMoreH) THEN
	    Hnew=H*FacRej
	 END IF
         RejectMoreH = RejectLastH
         RejectLastH = .TRUE.
         H = Hnew
         IF (Nacc.GE.1) THEN
	    Nrej = Nrej+1
	 END IF
      END IF ! Err <= 1

      END DO ! LOOP: WHILE STEP NOT ACCEPTED

101   CONTINUE

      END DO ! Time loop

!~~~> Succesful exit
      IERR = 1  !~~~> The integration was successful

      RETURN
      END  !  SUBROUTINE RosenbrockIntegrator

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      KPP_REAL FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr,
     &                      AbsTol, RelTol, VectorTol )
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!~~~> Computes the "scaled norm" of the error vector Yerr
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      IMPLICIT NONE
      INCLUDE 'KPP_ROOT_Parameters.h'

! Input arguments
      KPP_REAL Y(KPP_NVAR), Ynew(KPP_NVAR), Yerr(KPP_NVAR)
      KPP_REAL AbsTol(KPP_NVAR), RelTol(KPP_NVAR)
      LOGICAL  VectorTol
! Local variables
      KPP_REAL Err, Scale, Ymax, ZERO
      INTEGER i
      PARAMETER (ZERO = 0.0d0)

      Err = ZERO
      DO i=1,KPP_NVAR
	Ymax = MAX(ABS(Y(i)),ABS(Ynew(i)))
        IF (VectorTol) THEN
          Scale = AbsTol(i)+RelTol(i)*Ymax
        ELSE
          Scale = AbsTol(1)+RelTol(1)*Ymax
        END IF
        Err = Err+(Yerr(i)/Scale)**2
      END DO
      Err  = SQRT(Err/KPP_NVAR)

      ros_ErrorNorm = Err

      RETURN
      END ! FUNCTION ros_ErrorNorm

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y,
     &                       Fcn0, ode_Fun, dFdT )
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!~~~> The time partial derivative of the function by finite differences
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      IMPLICIT NONE
      INCLUDE 'KPP_ROOT_Parameters.h'

!~~~> Input arguments
      KPP_REAL T, Roundoff, Y(KPP_NVAR), Fcn0(KPP_NVAR)
      EXTERNAL ode_Fun
!~~~> Output arguments
      KPP_REAL dFdT(KPP_NVAR)
!~~~> Global variables
      INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng
      COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej,
     &       Ndec,Nsol,Nsng
!~~~> Local variables
      KPP_REAL Delta, DeltaMin, ONE
      PARAMETER ( DeltaMin = 1.0d-6 )
      PARAMETER ( ONE = 1.0d0 )

      Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T))
      CALL ode_Fun(T+Delta,Y,dFdT)
      CALL WAXPY(KPP_NVAR,(-ONE),Fcn0,1,dFdT,1)
      CALL WSCAL(KPP_NVAR,(ONE/Delta),dFdT,1)

      RETURN
      END ! SUBROUTINE ros_FunTimeDerivative

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE ros_PrepareMatrix ( H, Direction, gam,
     &                    Jac0, Ghimj, Pivot, Singular )
! --- --- --- --- --- --- --- --- --- --- --- --- ---
!  Prepares the LHS matrix for stage calculations
!  1.  Construct Ghimj = 1/(H*ham) - Jac0
!         "(Gamma H) Inverse Minus Jacobian"
!  2.  Repeat LU decomposition of Ghimj until successful.
!          -half the step size if LU decomposition fails and retry
!          -exit after 5 consecutive fails
! --- --- --- --- --- --- --- --- --- --- --- --- ---
      IMPLICIT NONE
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Sparse.h'

!~~~> Input arguments
      KPP_REAL gam, Jac0(KPP_LU_NONZERO)
      INTEGER  Direction
!~~~> Output arguments
      KPP_REAL Ghimj(KPP_LU_NONZERO)
      LOGICAL  Singular
      INTEGER  Pivot(KPP_NVAR)
!~~~> Inout arguments
      KPP_REAL H      ! step size is decreased when LU fails
!~~~> Global variables
      INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng
      COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej,
     &       Ndec,Nsol,Nsng
!~~~> Local variables
      INTEGER  i, ising, Nconsecutive
      KPP_REAL  ghinv, ONE, HALF
      PARAMETER ( ONE  = 1.0d0 )
      PARAMETER ( HALF = 0.5d0 )

      Nconsecutive = 0
      Singular = .TRUE.

      DO WHILE (Singular)

!~~~>    Construct Ghimj = 1/(H*ham) - Jac0
        CALL WCOPY(KPP_LU_NONZERO,Jac0,1,Ghimj,1)
        CALL WSCAL(KPP_LU_NONZERO,(-ONE),Ghimj,1)
        ghinv = ONE/(Direction*H*gam)
        DO i=1,KPP_NVAR
          Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv
        END DO
!~~~>    Compute LU decomposition
        CALL DecompTemplate( Ghimj, Pivot, ising )
        IF (ising .EQ. 0) THEN
!~~~>    If successful done
	  Singular = .FALSE.
	ELSE ! ising .ne. 0
!~~~>    If unsuccessful half the step size; if 5 consecutive fails then return
          Nsng = Nsng+1
          Nconsecutive = Nconsecutive+1
	  Singular = .TRUE.
	  PRINT*,'Warning: LU Decomposition returned ising = ',ising
          IF (Nconsecutive.LE.5) THEN ! Less than 5 consecutive failed decompositions
            H = H*HALF
	  ELSE  ! More than 5 consecutive failed decompositions
 	    RETURN
          END IF  ! Nconsecutive
        END IF	! ising

      END DO ! WHILE Singular

      RETURN
      END ! SUBROUTINE ros_PrepareMatrix

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE ros_ErrorMsg(Code,T,H,IERR)
      KPP_REAL T, H
      INTEGER IERR, Code

      IERR = Code
      WRITE(6,*)
     &   'Forced exit from Rosenbrock due to the following error:'

      IF    (Code .EQ. -1) THEN
         WRITE(6,*) '--> Improper value for maximal no of steps'
      ELSEIF (Code .EQ. -2) THEN
         WRITE(6,*) '--> Selected Rosenbrock method not implemented'
      ELSEIF (Code .EQ. -3) THEN
         WRITE(6,*) '--> Hmin/Hmax/Hstart must be positive'
      ELSEIF (Code .EQ. -4) THEN
         WRITE(6,*) '--> FacMin/FacMax/FacRej must be positive'
      ELSEIF (Code .EQ. -5) THEN
         WRITE(6,*) '--> Improper tolerance values'
      ELSEIF (Code .EQ. -6) THEN
         WRITE(6,*) '--> No of steps exceeds maximum bound'
      ELSEIF (Code .EQ. -7) THEN
         WRITE(6,*) '--> Step size too small: T + 10*H = T',
     &                ' or H < Roundoff'
      ELSEIF (Code .EQ. -8) THEN
         WRITE(6,*) '--> Matrix is repeatedly singular'
      ELSE
         WRITE(6,102) 'Unknown Error code: ',Code
      END IF

  102 FORMAT('       ',A,I4)
      WRITE(6,103) T, H

  103 FORMAT('        T=',E15.7,' and H=',E15.7)

      RETURN
      END

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE Ros2 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,
     &                ros_Gamma,ros_NewF,ros_ELO,ros_Name)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! --- AN L-STABLE METHOD, 2 stages, order 2
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      IMPLICIT NONE
      INTEGER S
      PARAMETER (S=2)
      INTEGER  ros_S
      KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2)
      KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO
      LOGICAL  ros_NewF(S)
      CHARACTER*12 ros_Name
      DOUBLE PRECISION g

       g = 1.0d0 + 1.0d0/SQRT(2.0d0)

!~~~> Name of the method
       ros_Name = 'ROS-2'
!~~~> Number of stages
       ros_S = 2

!~~~> The coefficient matrices A and C are strictly lower triangular.
!   The lower triangular (subdiagonal) elements are stored in row-wise order:
!   A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc.
!   The general mapping formula is:
!             A(i,j) = ros_A( (i-1)*(i-2)/2 + j )
!             C(i,j) = ros_C( (i-1)*(i-2)/2 + j )

       ros_A(1) = (1.d0)/g
       ros_C(1) = (-2.d0)/g
!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE)
!   or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE)
       ros_NewF(1) = .TRUE.
       ros_NewF(2) = .TRUE.
!~~~> M_i = Coefficients for new step solution
       ros_M(1)= (3.d0)/(2.d0*g)
       ros_M(2)= (1.d0)/(2.d0*g)
! E_i = Coefficients for error estimator
       ros_E(1) = 1.d0/(2.d0*g)
       ros_E(2) = 1.d0/(2.d0*g)
!~~~> ros_ELO = estimator of local order - the minimum between the
!       main and the embedded scheme orders plus one
       ros_ELO = 2.0d0
!~~~> Y_stage_i ~ Y( T + H*Alpha_i )
       ros_Alpha(1) = 0.0d0
       ros_Alpha(2) = 1.0d0
!~~~> Gamma_i = \sum_j  gamma_{i,j}
       ros_Gamma(1) = g
       ros_Gamma(2) =-g

      RETURN
      END ! SUBROUTINE Ros2

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE Ros3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,
     &               ros_Gamma,ros_NewF,ros_ELO,ros_Name)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      IMPLICIT NONE
      INTEGER S
      PARAMETER (S=3)
      INTEGER  ros_S
      KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2)
      KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO
      LOGICAL  ros_NewF(S)
      CHARACTER*12 ros_Name

!~~~> Name of the method
      ros_Name = 'ROS-3'
!~~~> Number of stages
      ros_S = 3

!~~~> The coefficient matrices A and C are strictly lower triangular.
!   The lower triangular (subdiagonal) elements are stored in row-wise order:
!   A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc.
!   The general mapping formula is:
!             A(i,j) = ros_A( (i-1)*(i-2)/2 + j )
!             C(i,j) = ros_C( (i-1)*(i-2)/2 + j )

      ros_A(1)= 1.d0
      ros_A(2)= 1.d0
      ros_A(3)= 0.d0

      ros_C(1) = -0.10156171083877702091975600115545d+01
      ros_C(2) =  0.40759956452537699824805835358067d+01
      ros_C(3) =  0.92076794298330791242156818474003d+01
!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE)
!   or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE)
      ros_NewF(1) = .TRUE.
      ros_NewF(2) = .TRUE.
      ros_NewF(3) = .FALSE.
!~~~> M_i = Coefficients for new step solution
      ros_M(1) =  0.1d+01
      ros_M(2) =  0.61697947043828245592553615689730d+01
      ros_M(3) = -0.42772256543218573326238373806514d+00
! E_i = Coefficients for error estimator
      ros_E(1) =  0.5d+00
      ros_E(2) = -0.29079558716805469821718236208017d+01
      ros_E(3) =  0.22354069897811569627360909276199d+00
!~~~> ros_ELO = estimator of local order - the minimum between the
!       main and the embedded scheme orders plus 1
      ros_ELO = 3.0d0
!~~~> Y_stage_i ~ Y( T + H*Alpha_i )
      ros_Alpha(1)= 0.0d+00
      ros_Alpha(2)= 0.43586652150845899941601945119356d+00
      ros_Alpha(3)= 0.43586652150845899941601945119356d+00
!~~~> Gamma_i = \sum_j  gamma_{i,j}
      ros_Gamma(1)= 0.43586652150845899941601945119356d+00
      ros_Gamma(2)= 0.24291996454816804366592249683314d+00
      ros_Gamma(3)= 0.21851380027664058511513169485832d+01
      RETURN
      END ! SUBROUTINE Ros3

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE Ros4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,
     &               ros_Gamma,ros_NewF,ros_ELO,ros_Name)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!     L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES
!     L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3
!
!         E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL
!         EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS.
!         SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
!         SPRINGER-VERLAG (1990)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      IMPLICIT NONE
      INTEGER S
      PARAMETER (S=4)
      INTEGER  ros_S
      KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2)
      KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO
      LOGICAL  ros_NewF(S)
      CHARACTER*12 ros_Name

!~~~> Name of the method
      ros_Name = 'ROS-4'
!~~~> Number of stages
      ros_S = 4

!~~~> The coefficient matrices A and C are strictly lower triangular.
!   The lower triangular (subdiagonal) elements are stored in row-wise order:
!   A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc.
!   The general mapping formula is:
!             A(i,j) = ros_A( (i-1)*(i-2)/2 + j )
!             C(i,j) = ros_C( (i-1)*(i-2)/2 + j )

      ros_A(1) = 0.2000000000000000d+01
      ros_A(2) = 0.1867943637803922d+01
      ros_A(3) = 0.2344449711399156d+00
      ros_A(4) = ros_A(2)
      ros_A(5) = ros_A(3)
      ros_A(6) = 0.0D0

      ros_C(1) =-0.7137615036412310d+01
      ros_C(2) = 0.2580708087951457d+01
      ros_C(3) = 0.6515950076447975d+00
      ros_C(4) =-0.2137148994382534d+01
      ros_C(5) =-0.3214669691237626d+00
      ros_C(6) =-0.6949742501781779d+00
!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE)
!   or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE)
      ros_NewF(1)  = .TRUE.
      ros_NewF(2)  = .TRUE.
      ros_NewF(3)  = .TRUE.
      ros_NewF(4)  = .FALSE.
!~~~> M_i = Coefficients for new step solution
      ros_M(1) = 0.2255570073418735d+01
      ros_M(2) = 0.2870493262186792d+00
      ros_M(3) = 0.4353179431840180d+00
      ros_M(4) = 0.1093502252409163d+01
!~~~> E_i  = Coefficients for error estimator
      ros_E(1) =-0.2815431932141155d+00
      ros_E(2) =-0.7276199124938920d-01
      ros_E(3) =-0.1082196201495311d+00
      ros_E(4) =-0.1093502252409163d+01
!~~~> ros_ELO  = estimator of local order - the minimum between the
!       main and the embedded scheme orders plus 1
      ros_ELO  = 4.0d0
!~~~> Y_stage_i ~ Y( T + H*Alpha_i )
      ros_Alpha(1) = 0.D0
      ros_Alpha(2) = 0.1145640000000000d+01
      ros_Alpha(3) = 0.6552168638155900d+00
      ros_Alpha(4) = ros_Alpha(3)
!~~~> Gamma_i = \sum_j  gamma_{i,j}
      ros_Gamma(1) = 0.5728200000000000d+00
      ros_Gamma(2) =-0.1769193891319233d+01
      ros_Gamma(3) = 0.7592633437920482d+00
      ros_Gamma(4) =-0.1049021087100450d+00
      RETURN
      END ! SUBROUTINE Ros4

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE Rodas3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,
     &                ros_Gamma,ros_NewF,ros_ELO,ros_Name)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! --- A STIFFLY-STABLE METHOD, 4 stages, order 3
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      IMPLICIT NONE
      INTEGER S
      PARAMETER (S=4)
      INTEGER  ros_S
      KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2)
      KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO
      LOGICAL  ros_NewF(S)
      CHARACTER*12 ros_Name

!~~~> Name of the method
      ros_Name = 'RODAS-3'
!~~~> Number of stages
      ros_S = 4

!~~~> The coefficient matrices A and C are strictly lower triangular.
!   The lower triangular (subdiagonal) elements are stored in row-wise order:
!   A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc.
!   The general mapping formula is:
!             A(i,j) = ros_A( (i-1)*(i-2)/2 + j )
!             C(i,j) = ros_C( (i-1)*(i-2)/2 + j )

      ros_A(1) = 0.0d+00
      ros_A(2) = 2.0d+00
      ros_A(3) = 0.0d+00
      ros_A(4) = 2.0d+00
      ros_A(5) = 0.0d+00
      ros_A(6) = 1.0d+00

      ros_C(1) = 4.0d+00
      ros_C(2) = 1.0d+00
      ros_C(3) =-1.0d+00
      ros_C(4) = 1.0d+00
      ros_C(5) =-1.0d+00
      ros_C(6) =-(8.0d+00/3.0d+00)

!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE)
!   or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE)
      ros_NewF(1)  = .TRUE.
      ros_NewF(2)  = .FALSE.
      ros_NewF(3)  = .TRUE.
      ros_NewF(4)  = .TRUE.
!~~~> M_i = Coefficients for new step solution
      ros_M(1) = 2.0d+00
      ros_M(2) = 0.0d+00
      ros_M(3) = 1.0d+00
      ros_M(4) = 1.0d+00
!~~~> E_i  = Coefficients for error estimator
      ros_E(1) = 0.0d+00
      ros_E(2) = 0.0d+00
      ros_E(3) = 0.0d+00
      ros_E(4) = 1.0d+00
!~~~> ros_ELO  = estimator of local order - the minimum between the
!       main and the embedded scheme orders plus 1
      ros_ELO  = 3.0d+00
!~~~> Y_stage_i ~ Y( T + H*Alpha_i )
      ros_Alpha(1) = 0.0d+00
      ros_Alpha(2) = 0.0d+00
      ros_Alpha(3) = 1.0d+00
      ros_Alpha(4) = 1.0d+00
!~~~> Gamma_i = \sum_j  gamma_{i,j}
      ros_Gamma(1) = 0.5d+00
      ros_Gamma(2) = 1.5d+00
      ros_Gamma(3) = 0.0d+00
      ros_Gamma(4) = 0.0d+00
      RETURN
      END ! SUBROUTINE Rodas3

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE Rodas4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,
     &                 ros_Gamma,ros_NewF,ros_ELO,ros_Name)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!     STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES
!
!         E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL
!         EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS.
!         SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
!         SPRINGER-VERLAG (1996)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      IMPLICIT NONE
      INTEGER S
      PARAMETER (S=6)
      INTEGER  ros_S
      KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2)
      KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO
      LOGICAL  ros_NewF(S)
      CHARACTER*12 ros_Name

!~~~> Name of the method
       ros_Name = 'RODAS-4'
!~~~> Number of stages
       ros_S = 6

!~~~> Y_stage_i ~ Y( T + H*Alpha_i )
       ros_Alpha(1) = 0.000d0
       ros_Alpha(2) = 0.386d0
       ros_Alpha(3) = 0.210d0
       ros_Alpha(4) = 0.630d0
       ros_Alpha(5) = 1.000d0
       ros_Alpha(6) = 1.000d0

!~~~> Gamma_i = \sum_j  gamma_{i,j}
       ros_Gamma(1) = 0.2500000000000000d+00
       ros_Gamma(2) =-0.1043000000000000d+00
       ros_Gamma(3) = 0.1035000000000000d+00
       ros_Gamma(4) =-0.3620000000000023d-01
       ros_Gamma(5) = 0.0d0
       ros_Gamma(6) = 0.0d0

!~~~> The coefficient matrices A and C are strictly lower triangular.
!   The lower triangular (subdiagonal) elements are stored in row-wise order:
!   A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc.
!   The general mapping formula is:  A(i,j) = ros_A( (i-1)*(i-2)/2 + j )
!                                    C(i,j) = ros_C( (i-1)*(i-2)/2 + j )

       ros_A(1) = 0.1544000000000000d+01
       ros_A(2) = 0.9466785280815826d+00
       ros_A(3) = 0.2557011698983284d+00
       ros_A(4) = 0.3314825187068521d+01
       ros_A(5) = 0.2896124015972201d+01
       ros_A(6) = 0.9986419139977817d+00
       ros_A(7) = 0.1221224509226641d+01
       ros_A(8) = 0.6019134481288629d+01
       ros_A(9) = 0.1253708332932087d+02
       ros_A(10) =-0.6878860361058950d+00
       ros_A(11) = ros_A(7)
       ros_A(12) = ros_A(8)
       ros_A(13) = ros_A(9)
       ros_A(14) = ros_A(10)
       ros_A(15) = 1.0d+00

       ros_C(1) =-0.5668800000000000d+01
       ros_C(2) =-0.2430093356833875d+01
       ros_C(3) =-0.2063599157091915d+00
       ros_C(4) =-0.1073529058151375d+00
       ros_C(5) =-0.9594562251023355d+01
       ros_C(6) =-0.2047028614809616d+02
       ros_C(7) = 0.7496443313967647d+01
       ros_C(8) =-0.1024680431464352d+02
       ros_C(9) =-0.3399990352819905d+02
       ros_C(10) = 0.1170890893206160d+02
       ros_C(11) = 0.8083246795921522d+01
       ros_C(12) =-0.7981132988064893d+01
       ros_C(13) =-0.3152159432874371d+02
       ros_C(14) = 0.1631930543123136d+02
       ros_C(15) =-0.6058818238834054d+01

!~~~> M_i = Coefficients for new step solution
       ros_M(1) = ros_A(7)
       ros_M(2) = ros_A(8)
       ros_M(3) = ros_A(9)
       ros_M(4) = ros_A(10)
       ros_M(5) = 1.0d+00
       ros_M(6) = 1.0d+00

!~~~> E_i  = Coefficients for error estimator
       ros_E(1) = 0.0d+00
       ros_E(2) = 0.0d+00
       ros_E(3) = 0.0d+00
       ros_E(4) = 0.0d+00
       ros_E(5) = 0.0d+00
       ros_E(6) = 1.0d+00

!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE)
!   or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE)
       ros_NewF(1) = .TRUE.
       ros_NewF(2) = .TRUE.
       ros_NewF(3) = .TRUE.
       ros_NewF(4) = .TRUE.
       ros_NewF(5) = .TRUE.
       ros_NewF(6) = .TRUE.

!~~~> ros_ELO  = estimator of local order - the minimum between the
!       main and the embedded scheme orders plus 1
       ros_ELO = 4.0d0

      RETURN
      END ! SUBROUTINE Rodas4

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE DecompTemplate( A, Pivot, ising )
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  Template for the LU decomposition
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'
!~~~> Inout variables
      KPP_REAL A(KPP_LU_NONZERO)
!~~~> Output variables
      INTEGER Pivot(KPP_NVAR), ising
!~~~> Collect statistics
      INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng
      COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej,
     &       Ndec,Nsol,Nsng

      CALL KppDecomp ( A, ising )
!~~~> Note: for a full matrix use Lapack:
!        CALL  DGETRF( KPP_NVAR, KPP_NVAR, A, KPP_NVAR, Pivot, ising )

      Ndec = Ndec + 1

      END ! SUBROUTINE DecompTemplate

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE SolveTemplate( A, Pivot, b )
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  Template for the forward/backward substitution (using pre-computed LU decomposition)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'
!~~~> Input variables
      KPP_REAL A(KPP_LU_NONZERO)
      INTEGER Pivot(KPP_NVAR)
!~~~> InOut variables
      KPP_REAL b(KPP_NVAR)
!~~~> Collect statistics
      INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng
      COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej,
     &       Ndec,Nsol,Nsng

      CALL KppSolve( A, b )
!~~~> Note: for a full matrix use Lapack:
!        NRHS = 1
!        CALL  DGETRS( 'N', KPP_NVAR , NRHS, A, KPP_NVAR, Pivot, b, KPP_NVAR, INFO )

      Nsol = Nsol+1

      END ! SUBROUTINE SolveTemplate

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE FunTemplate( T, Y, Ydot )
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  Template for the ODE function call.
!  Updates the rate coefficients (and possibly the fixed species) at each call
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'
!~~~> Input variables
      KPP_REAL T, Y(KPP_NVAR)
!~~~> Output variables
      KPP_REAL Ydot(KPP_NVAR)
!~~~> Local variables
      KPP_REAL Told
!~~~> Collect statistics
      INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng
      COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej,
     &       Ndec,Nsol,Nsng

      Told = TIME
      TIME = T
      CALL Update_SUN()
      CALL Update_RCONST()
      CALL Fun( Y, FIX, RCONST, Ydot )
      TIME = Told

      Nfun = Nfun+1

      RETURN
      END ! SUBROUTINE FunTemplate

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      SUBROUTINE JacTemplate( T, Y, Jcb )
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  Template for the ODE Jacobian call.
!  Updates the rate coefficients (and possibly the fixed species) at each call
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'
!~~~> Input variables
      KPP_REAL T, Y(KPP_NVAR)
!~~~> Output variables
      KPP_REAL Jcb(KPP_LU_NONZERO)
!~~~> Local variables
      KPP_REAL Told
!~~~> Collect statistics
      INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng
      COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej,
     &       Ndec,Nsol,Nsng

      Told = TIME
      TIME = T
      CALL Update_SUN()
      CALL Update_RCONST()
      CALL Jac_SP( Y, FIX, RCONST, Jcb )
      TIME = Told

      Njac = Njac+1

      RETURN
      END !  SUBROUTINE JacTemplate


!------------------------------------------------------------------
!Module containing the subroutines for determining
!each of the symmetry elements:
!-----------------------------------------------------------------
!
module symmetry_elements
implicit none
contains
!
!------------------------------------------------------------------
!Subroutine for inversion center:
!-----------------------------------------------------------------
!
subroutine inversion (mat1, n, logic, stdev)
implicit none
!
!-----------------------------------------------------------------
!This subroutine checks if the molecule has an inversion center
!The only input that it requires is the specification of the molecular
!structure in matrix form (mat1) and the number of atoms
!in the molecule
!----------------------------------------------------------------------
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), allocatable, dimension(:,:), intent(in) :: mat1 !input matrix
real(dp), allocatable, dimension(:,:) :: mat2 !inverted matrix
integer,intent(in) :: n !dimension of matrix
integer, intent(out) :: logic !1 or 0.
integer :: i, j !counters
real(dp), intent(out) :: stdev  !standard deviation from perfect symmetry
!
allocate (mat2(4,n))
!
do i = 1, n
    mat2(1,i) = mat1(1,i) !the first column contains the atomic masses
end do
!
do i = 2, 4 !it starts from 2 because the first column contains atomic mass
    do j = 1, n
        mat2(i,j) = -(mat1(i,j))
    end do
end do
!
call compare (mat1, mat2, n, logic, stdev)
!
end subroutine inversion
!
!--------------------------------
!subroutine to check for the existence of a horisontal
!reflection plane
!--------------------------------
!
subroutine horisontal(mat1, n, logic, stdev)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), allocatable, dimension(:,:), intent(in) :: mat1 !input matrix
real(dp), allocatable, dimension(:,:) :: mat2 !reflected matrix
integer,intent(in) :: n !dimension of matrix
integer, intent(out) :: logic !1 or 0.
integer :: i, j !counters
real(dp), intent(out) :: stdev
!
allocate (mat2(4,n))
!
do i = 1, n
    mat2(1,i) = mat1(1,i)
    mat2(2,i) = mat1(2,i)
    mat2(3,i) = mat1(3,i)
    mat2(4,i) = -mat1(4,i) !reflection in the xy - plane
end do
!
!I am assuming that when this subroutine is run, the molecule is already
!aligned along the main rotation axis
!
call compare (mat1, mat2, n, logic, stdev)
!
end subroutine horisontal
!
!-------------------------------------------
!subroutine for vertical reflection plane
!----------------------------------------------
!
subroutine vertical(mol1, ref_point, n, logic, stdev)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), dimension(3,1), intent(in) :: ref_point !SEA or midpoint
real(dp), dimension(3,3) :: Rz
real(dp) :: sinz, cosz
real(dp), allocatable, dimension(:,:), intent(in) :: mol1
real(dp), allocatable, dimension(:,:) :: mol2, mol3, coordinates, rotated
integer :: n !dimension
integer, intent(out) :: logic !0 or 1
integer :: i, j
real(dp), intent(out) :: stdev
!
allocate( coordinates(3,n), rotated(3,n), mol2(4,n), mol3(4,n) )
!
!----------------------------------------------------
!aligning refference point with x - axis:
!-----------------------------------------------------
!
do i = 1, 3
    do j = 1, n
        coordinates(i,j) = mol1(i+1,j) !transfer coordinates from molecule
                                        !matrix
    end do
end do
!
cosz = ref_point(1,1)/sqrt( (ref_point(1,1))**(2.)+(ref_point(2,1))**(2.) )
sinz = ref_point(2,1)/sqrt( (ref_point(1,1))**(2.)+(ref_point(2,1))**(2.) )
!
call z_rotation_matrix(cosz, sinz, Rz)
!
rotated = matmul(Rz, coordinates)
!
do i = 1, 3
    do j = 1, n
        mol2(i+1,j) = rotated(i,j) !transfer rotated coordinates to
                                    !to molecule matrix.
    end do
end do
!
do i = 1, n
    mol2(1,i) = mol1(1,i) !atomic masses
end do
!
!---------------------------------------------
!molecule after reflection along the xz axis:
!---------------------------------------------
!
do i = 1, n
    mol3(1,i) = mol2(1,i)
    mol3(2,i) = mol2(2,i)
    mol3(3,i) = - mol2(3,i) ! y - coordinate (xz plane)
    mol3(4,i) = mol2(4,i)
end do
!
call compare(mol2, mol3, n, logic, stdev)
!
end subroutine vertical
!
!----------------------------------------------------------
!subroutine to check for secondary rotation axis
!-----------------------------------------------------------
!
subroutine secondary_rotation (mol, ref_point, n, logic, stdev)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), dimension(3,1), intent(in) :: ref_point !the point through which
                             !the axis should pass
real(dp), allocatable, dimension(:,:), intent(in) ::  mol
integer, intent(in) :: n
real(dp), allocatable, dimension(:,:) :: mol1, mol2
real(dp), dimension(3,1) :: vecz
integer, intent(out) :: logic !1 or 2
real(dp), dimension(3,3) :: Rz, Ry
integer, parameter :: r = 2 !second order rotation matrix
real(dp), intent(out) :: stdev
!
allocate (mol1(4,n), mol2(4,n))
!
call align (ref_point, mol, n, vecz, mol1)
!
call rotation(mol1, n, r, mol2)
!
call compare (mol1, mol2, n, logic, stdev)
!
end subroutine secondary_rotation
!
!-----------------------------------------
!Subroutine for the S2n point groups:
!-----------------------------------------
!
subroutine rotoinversion (mol1, n, ord, logic, stdev)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:,:), intent(in) :: mol1
real(dp), allocatable, dimension(:,:) :: mol2, mol3
integer, intent(in) :: ord !order of rotation
integer, intent(in) :: n !dimension of matrix
integer, intent(out) :: logic ! 1 or 0
integer :: i !counter
real(dp), intent(out) :: stdev
!
allocate(mol2(4,n), mol3(4,n))
!
call rotation (mol1, n, ord, mol2)
!
do i = 1, n
    mol3(1,i) = mol2(1,i)
    mol3(2,i) = mol2(2,i)
    mol3(3,i) = mol2(3,i)
    mol3(4,i) = -mol2(4,i) !reflection in the xy - plane
end do
!
call compare (mol1, mol3, n, logic, stdev)
!
end subroutine rotoinversion
!
!-----------------------------------------------------------------
!Subroutine to compare two matrices (molecular structures), to see
!if they are trully identical.
!-----------------------------------------------------------------
!
subroutine compare (matrix1, matrix2, n, prod, average_deviation)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
integer :: i, j, k !counters
!
real(dp), allocatable, dimension(:,:), intent(in) :: matrix1, matrix2
real(dp), allocatable, dimension(:,:) :: coordinates, coordinates1
integer, intent(in) :: n !dimension
integer, allocatable, dimension (:) :: comparison, B, BB ! comparison array
integer, intent(out) :: prod ! for the product for the comparison
real, allocatable, dimension(:) :: dist !euclidian distance between points
real(dp), intent(out) :: average_deviation ! deviation from perfect symmetry
!
allocate (comparison(n), B(n), BB(n), dist(n))
!========================================================
!----NOTE TO SELF:---------------------------------------
allocate (coordinates(3,n), coordinates1(3,n))
!coordinates arrays are probably not necessary here.
!Either that, or do the comparison on them, rather than
!on the matrix arrays
!========================================================
!
do i = 1, 3
    do j = 1, n
        coordinates(i,j) = matrix1(i+1,j)
        coordinates1(i,j) = matrix2(i+1,j)
    end do
end do
do i = 1, n !set them to 0 at the start of the comparison.
    B(i) = 0
    comparison(i) = 0
    BB(i) = 0
end do
!
!--------------------------------------------------------------------
!check if for every atom in matrix1, there is an atom in matrix2 that
!has is of the same element and has the same set of coordinates:
!--------------------------------------------------------------------
!
call norm (n, coordinates) !probably not necessary to scale.
                             !besides, you're doing everything on the
                             !matrix array.
call norm (n, coordinates1)
do i = 1, n
    do j = 1, n
        if (j == B(j)) cycle
        if (i == BB(i)) cycle
        if (abs(matrix1(1,i) - matrix2(1,j)) .LE. 0.015) then
            if (abs(matrix1(2,i) - matrix2(2,j)) .LE. 0.015) then
                if (abs(matrix1(3,i) - matrix2(3,j)) .LE. 0.015) then
                    if (abs(matrix1(4,i) - matrix2(4,j)) .LE. 0.015) then
                        comparison(i) = 1
                        B(j) = j
                        BB(i) = i
        dist(i) = sqrt( ((coordinates(1,i)) - (coordinates1(1,j)))**(2) + &
            ((coordinates(2,i)) - (coordinates1(2,j)))**(2) + &
            ((coordinates(3,i)) - (coordinates1(3,j)))**(2) )
                    end if
                end if
            end if
        end if
    end do
end do
!
!---------------------------------------------------------------------
!and now to see if all the matrix elements have been found to be equal
!and if so, what is the deviation from perfect symmetry:
!----------------------------------------------------------------------
!
prod = 1
do i = 1, n
    prod = prod * comparison(i)
end do
!
if (prod == 1) then
    average_deviation = 0
    do i = 1, n
        average_deviation = average_deviation + dist(i)
    end do
    average_deviation = average_deviation/dble(n)
end if
!
end subroutine compare
!
!----------------------------------------------------------
!Align the molecule so that the selcted moment of inertia
!or refference point is along
!the z - axis of the cartesian coordinate system:
!-----------------------------------------------------------
!
subroutine align (vector, mol, n, vecz, mol1)
implicit none
!
!-----------------------------------------------------------------
!This subroutine aligns the axis of interest with the z - axis.
!it does this by determining the sine and cosine for the
!axis in question based on its position relative to the coordinate system,
!building the rotation matrices for rotation around the y - and x -
!matrices and then applying them to every atom in the molecule.
!
!This is equivalent to either rotating the entire
!molecule, or "moving space", i.e. rotating the coordinate system,
!to allow the moment of inertia to be aligned with the z - axis
!--------------------------------------------------------------
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), dimension(3,1), intent(in) :: vector
real(dp), dimension(3,1) :: vecxz !rotation around x-axis to
                !move the vector
                    !to the xz plane
real(dp), dimension(3,1), intent(out) :: vecz ! the vector is aligned
                    !with z - axis after rotation around y - axis
integer, intent(in) :: n !number of atoms in the molecule
real(dp), allocatable, dimension(:,:), intent(in) :: mol !input molecule
real(dp), allocatable, dimension(:,:) :: coordinates, rotated1, rotated2
                    !working functions
real(dp) :: cosx, sinx, cosy, siny ! to rotate space about the x & y - axes
real(dp), dimension(3,3) :: Rx, Ry!Rotation about x & y - axes
real(dp), allocatable, dimension(:,:), intent(out) :: mol1
integer :: i, j !counter
!
allocate (coordinates(3,n))
allocate (rotated1(3,n), rotated2(3,n))
allocate (mol1(4,n))
!
do i = 1, 3
    do j = 1, n
        coordinates(i,j) = mol(i+1,j)
    end do
end do
!
if (vector(1,1) == 0) then
    if (vector(2,1) /= 0) then
        !
        !----------------------------
        ! [0,y,z]
        !--------------------------
        !
            !----------------------------------------------
            !find matrix for rotation about the x-axis
            !-----------------------------------------------
!
            cosx=vector(3,1)/sqrt( vector(2,1)**(2.) + vector(3,1)**(2.) )
            sinx=vector(2,1)/sqrt( vector(2,1)**(2.) + vector(3,1)**(2.) )
!
            call x_rotation_matrix (cosx, sinx, Rx)
!
            !--------------------------------------------------------
            !rotate space about the x - axis to bring the inertia vector in
            !the xz-plane:
            !----------------------------------------------------------
!
            rotated1 = matmul(Rx,coordinates)
            vecz = matmul(Rx,vector)
!
            do i = 1, n
                mol1(1,i) = mol(1,i) ! just transferring the atomic masses
            end do
!
            do i = 1, 3
                do j = 1, n
                    mol1(i+1,j) = rotated1(i,j)
                end do
            end do
!
    else if (vector(2,1) == 0) then
    !
    !-------------------------------------------
    ! [0,0,z]
    !-----------------------------------------------
    !
        vecz = vector
        mol1 = mol
    end if
end if
!
!
if (vector(2,1) == 0) then
    if (vector(1,1) /= 0) then
    !
    !----------------------------------------------
    ! [x, 0, z]
    !----------------------------------------------------
    !
        !---------------------------------------------------
        !find matrix for rotation about the y-axis
        !---------------------------------------------------
!
        cosy = vector(3,1)/sqrt(vector(1,1)**(2.) + vector(3,1)**(2.))
        siny = vector(1,1)/sqrt(vector(1,1)**(2.) + vector(3,1)**(2.))
!
        call y_rotation_matrix (cosy, siny, Ry)
!
        !-------------------------------------------------------------
        !rotate space around the y - axis, so that the rotation axis lies
        !along the positive z - axis
        !----------------------------------------------------------------
!
        rotated2 = matmul(Ry,coordinates)
        vecz = matmul(Ry,vector) !should have the form [0,0,z]
!
        do i = 1, n
            mol1(1,i) = mol(1,i) ! just transferring the atomic masses
        end do
!
        do i = 1, 3
            do j = 1, n
                mol1(i+1,j) = rotated2(i,j)
            end do
        end do
    end if
end if
!
if (vector(1,1) /= 0 ) then
    if (vector(2,1) /= 0) then
    !
    !--------------------------------------
    ! [x, y, z]
    !---------------------------------------
    !
        !----------------------------------------------
        !find matrix for rotation about the x-axis
        !-----------------------------------------------
!
        cosx = vector(3,1)/sqrt( vector(2,1)**(2.) + vector(3,1)**(2.) )
        sinx = vector(2,1)/sqrt( vector(2,1)**(2.) + vector(3,1)**(2.) )
!
        call x_rotation_matrix (cosx, sinx, Rx)
!
        !--------------------------------------------------------
        !rotate space about the x - axis to bring the inertia vector in
        !the xz-plane:
        !----------------------------------------------------------
!
        rotated1 = matmul(Rx,coordinates)
        vecxz = matmul(Rx,vector)
!
        !---------------------------------------------------
        !find matrix for rotation about the y-axis
        !---------------------------------------------------
!
        cosy = vecxz(3,1)/sqrt( vecxz(1,1)**(2.) + vecxz(3,1)**(2.) )
        siny = vecxz(1,1)/sqrt( vecxz(1,1)**(2.) + vecxz(3,1)**(2.) )
!
        call y_rotation_matrix (cosy, siny, Ry)
!
        !-------------------------------------------------------------
        !rotate space around the y - axis, so that the rotation axis lies
        !along the positive z - axis
        !----------------------------------------------------------------
!
        rotated2 = matmul(Ry,rotated1)
        vecz = matmul(Ry,vecxz) !should have the form [0,0,z]
!
        do i = 1, n
            mol1(1,i) = mol(1,i) ! just transferring the atomic masses
        end do
!
        do i = 1, 3
            do j = 1, n
                mol1(i+1,j) = rotated2(i,j)
            end do
        end do
    end if
end if
!
end subroutine align
!
!---------------------------------------------------------
!Subroutine to perform rotations around the z - axis:
!---------------------------------------------------------
!
subroutine rotation(mol, n, r, molz)
implicit none
!
!------------------------------------------------------------
!This subroutine rotates a molecule around the z - axis of the coordinate
!system by an angle defined in the call of the subroutine.
!-------------------------------------------------------------
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), allocatable, dimension(:,:), intent(in) :: mol
real(dp), allocatable, dimension(:,:) :: coordinates, rotated
real(dp), dimension(3,3) :: Rz ! rotation axis
integer, intent(in) :: n !dimension of molecule
integer, intent(in) :: r !order of rotation axis
real(dp), allocatable, dimension(:,:), intent(out) :: molz
real(dp), parameter :: pi = 3.141592653589793
real(dp) :: cosz, sinz, k ! = real(n)
integer :: i, j !counters
!
allocate (molz(4,n), coordinates(3,n), rotated(3,n))
!
do i = 1, 3
    do j = 1, n
        coordinates(i,j) = mol(i+1,j)
    end do
end do
!
k = real(r)
cosz = cos(((2.)*pi)/k)
sinz = sin(((2.)*pi)/k)
!
call z_rotation_matrix (cosz, sinz, Rz)
!
rotated = matmul(Rz,coordinates)
!
do i = 1, n
    molz(1,i) = mol(1,i) ! just transferring the atomic masses
end do
!
do i = 1, 3
    do j = 1, n
        molz(i+1,j) = rotated(i,j)
    end do
end do
!
end subroutine rotation
!
!-----------------------------------------------------------
!subroutines to generate the rotation matrices:
!---------------------------------------------------------
!
subroutine x_rotation_matrix (cosx, sinx, Rx)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), intent(in) :: cosx, sinx
real(dp), dimension(3,3), intent(out) :: Rx
!
Rx(1,1)=1
Rx(1,2)=0
Rx(1,3)=0
Rx(2,1)=0
Rx(2,2)=cosx
Rx(2,3)=-sinx
Rx(3,1)=0
Rx(3,2)=sinx
Rx(3,3)=cosx
!
end subroutine x_rotation_matrix
!
subroutine y_rotation_matrix (cosy, siny, Ry)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), intent(in) :: cosy, siny
real(dp), dimension(3,3), intent(out) :: Ry
!
Ry(1,1)=cosy
Ry(1,2)=0
Ry(1,3)=-siny
Ry(2,1)=0
Ry(2,2)=1
Ry(2,3)=0
Ry(3,1)=siny
Ry(3,2)=0
Ry(3,3)=cosy
!
end subroutine y_rotation_matrix
!
subroutine z_rotation_matrix(cosz, sinz, Rz)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), intent(in) :: sinz, cosz
real(dp), dimension(3,3), intent(out) :: Rz
!
Rz(1,1)=cosz
Rz(1,2)=-sinz
Rz(1,3)=0
Rz(2,1)=sinz
Rz(2,2)=cosz
Rz(2,3)=0
Rz(3,1)=0
Rz(3,2)=0
Rz(3,3)=1
!
end subroutine z_rotation_matrix
!
!-----------------------------------------
!subroutine to scale the longest distance to the CM
!in the molecule to 1:
!-----------------------------------------
!
subroutine norm (n, coord)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), allocatable, dimension(:,:), intent(inout) :: coord
real(dp), allocatable, dimension(:) :: distance
integer, intent(in) :: n
integer :: i, j
real(dp) :: maxdist, scalefac !maximum distance from center of mass and
                        !scale factor
allocate( distance(n) )
!
do j = 1, n
    distance(j) = sqrt( coord(1,j)**(2.) + coord(2,j)**(2.) &
        + coord(3,j)**(2.) )
end do
!
maxdist = maxval(distance)
!
scalefac = (1.)/maxdist
!
do i = 1, 3
    do j = 1, n
        coord(i,j) = coord(i,j)*scalefac
    end do
end do
!
end subroutine norm
!
end module symmetry_elements


      SUBROUTINE LFACTR (A,NROW,IX1,IX2,IP)
C
C     LFACTR PERFORMS GAUSS-DOOLITTLE MANIPULATIONS ON THE TWO BLOCKS OF
C     THE TRANSPOSED MATRIX IN CORE STORAGE.  THE GAUSS-DOOLITTLE
C     ALGORITHM IS PRESENTED ON PAGES 411-416 OF A. RALSTON -- A FIRST
C     COURSE IN NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN
C     RALSTONS TEXT.
C
      COMPLEX A,D,AJR
      INTEGER R,R1,R2,PJ,PR
      LOGICAL L1,L2,L3
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
      COMMON /SCRATM/ D(600)
      DIMENSION A(NROW,1), IP(NROW)
      IFLG=0
C
C     INITIALIZE R1,R2,J1,J2
C
      L1=IX1.EQ.1.AND.IX2.EQ.2
      L2=(IX2-1).EQ.IX1
      L3=IX2.EQ.NBLSYM
      IF (L1) GO TO 1
      GO TO 2
1     R1=1
      R2=2*NPSYM
      J1=1
      J2=-1
      GO TO 5
2     R1=NPSYM+1
      R2=2*NPSYM
      J1=(IX1-1)*NPSYM+1
      IF (L2) GO TO 3
      GO TO 4
3     J2=J1+NPSYM-2
      GO TO 5
4     J2=J1+NPSYM-1
5     IF (L3) R2=NPSYM+NLSYM
      DO 16 R=R1,R2
C
C     STEP 1
C
      DO 6 K=J1,NROW
      D(K)=A(K,R)
6     CONTINUE
C
C     STEPS 2 AND 3
C
      IF (L1.OR.L2) J2=J2+1
      IF (J1.GT.J2) GO TO 9
      IXJ=0
      DO 8 J=J1,J2
      IXJ=IXJ+1
      PJ=IP(J)
      AJR=D(PJ)
      A(J,R)=AJR
      D(PJ)=D(J)
      JP1=J+1
      DO 7 I=JP1,NROW
      D(I)=D(I)-A(I,IXJ)*AJR
7     CONTINUE
8     CONTINUE
9     CONTINUE
C
C     STEP 4
C
      J2P1=J2+1
      IF (L1.OR.L2) GO TO 11
      IF (NROW.LT.J2P1) GO TO 16
      DO 10 I=J2P1,NROW
      A(I,R)=D(I)
10    CONTINUE
      GO TO 16
11    DMAX=REAL(D(J2P1)*CONJG(D(J2P1)))
      IP(J2P1)=J2P1
      J2P2=J2+2
      IF (J2P2.GT.NROW) GO TO 13
      DO 12 I=J2P2,NROW
      ELMAG=REAL(D(I)*CONJG(D(I)))
      IF (ELMAG.LT.DMAX) GO TO 12
      DMAX=ELMAG
      IP(J2P1)=I
12    CONTINUE
13    CONTINUE
      IF (DMAX.LT.1.E-10) IFLG=1
      PR=IP(J2P1)
      A(J2P1,R)=D(PR)
      D(PR)=D(J2P1)
C
C     STEP 5
C
      IF (J2P2.GT.NROW) GO TO 15
      AJR=1./A(J2P1,R)
      DO 14 I=J2P2,NROW
      A(I,R)=D(I)*AJR
14    CONTINUE
15    CONTINUE
      IF (IFLG.EQ.0) GO TO 16
      PRINT 17, J2,DMAX
      IFLG=0
16    CONTINUE
      RETURN
C
17    FORMAT (1H ,6HPIVOT(,I3,2H)=,1P,E16.8)
      END


program Pointpoly
  use Points_Module
  use Ray_Casting_Algo
  implicit none

  character(len=16), dimension(4) :: names
  type(polygon), dimension(4) :: polys
  type(point), dimension(14) :: pts
  type(point), dimension(7) :: p

  integer :: i, j

  pts = (/ point(0,0), point(10,0), point(10,10), point(0,10), &
           point(2.5,2.5), point(7.5,2.5), point(7.5,7.5), point(2.5,7.5), &
           point(0,5), point(10,5), &
           point(3,0), point(7,0), point(7,10), point(3,10) /)

  polys(1) = create_polygon(pts, (/ 1,2, 2,3, 3,4, 4,1 /) )
  polys(2) = create_polygon(pts, (/ 1,2, 2,3, 3,4, 4,1, 5,6, 6,7, 7,8, 8,5 /) )
  polys(3) = create_polygon(pts, (/ 1,5, 5,4, 4,8, 8,7, 7,3, 3,2, 2,5 /) )
  polys(4) = create_polygon(pts, (/ 11,12, 12,10, 10,13, 13,14, 14,9, 9,11 /) )

  names = (/ "square", "square hole", "strange", "hexagon" /)

  p = (/ point(5,5), point(5, 8), point(-10, 5), point(0,5), point(10,5), &
         point(8,5), point(10,10) /)

  do j = 1, size(p)
     do i = 1, size(polys)
        write(*, "('point (',F8.2,',',F8.2,') is inside ',A,'? ', L)") &
             p(j)%x, p(j)%y, names(i), point_is_inside(p(j), polys(i))
     end do
     print *, ""
  end do

  do i = 1, size(polys)
     call free_polygon(polys(i))
  end do

end program Pointpoly


! ----------------------------------------------------------------------
      subroutine bn_bfield_parallel
! ----------------------------------------------------------------------
c                                                            11.09.99
c     purpose:
c
c
c ----------------------------------------------------------------------
      use meshes
      use bnvariables
      implicit none
      integer :: i, m, n
      real(rprec) :: cop, sip
c ----------------------------------------------------------------------
      curpol = alp*bsubv(0,0)
c     write(6,3000) curpol
 3000 format('   curpol= ',1pe12.4)
      do m=  0,md
         do n=-nd,nd
            bsubu(m,n) = pi2*bsubu(m,n)/curpol
            bsubv(m,n) = alp*bsubv(m,n)/curpol
            bsubus(m,n) = pi2*bsubus(m,n)/curpol
            bsubvs(m,n) = alp*bsubvs(m,n)/curpol
         enddo
      enddo

      do  i = 1 , nuv
         bu (i)   = 0._dp
         bv (i)   = 0._dp
      enddo

      do  m = 0,mb
         do  n = -nb,nb
            do  i  = 1,nuv
               cop      = conu(i,m)*conv(i,n)-sinu(i,m)*sinv(i,n)       !cos(u+v)
               sip      = sinu(i,m)*conv(i,n)+conu(i,m)*sinv(i,n)       !sin(u+v)
               bu (i)   = bu (i) + bsubu(m,n)*cop
     1                           + bsubus(m,n)*sip
               bv (i)   = bv (i) + bsubv(m,n)*cop
     1                           + bsubvs(m,n)*sip
            enddo
         enddo
      enddo

      end subroutine   bn_bfield_parallel


!--------------------------------------------------------------------!
!      This code is a part of GASS Reweighting codes                 !
! Fortran program to calculate the 2D probability distribution after !
! reweighting the metadynamics bias potentail in GASS sumulation     !
!--------------------------------------------------------------------!
!
PROGRAM prob_factor
IMPLICIT NONE
REAL*8 :: gridmin1, gridmax1, griddiff1, gridmin2, gridmax2, griddiff2
REAL*8 :: gridmin3, gridmax3, griddiff3, gridmin4, gridmax4, griddiff4
REAL*8 :: T0, T, ktb, bias_fact, alpha_cv, deltaT, den,kbT, kbT0
REAL*8 :: diff_s2, ds2, ss, hh, dum, num, alpha
REAL*8, ALLOCATABLE :: prob(:,:)
REAL*8, ALLOCATABLE :: cv1(:), cv2(:), vbias(:),s1,s2, s3, s4
REAL*8, ALLOCATABLE :: cv3(:), cv4(:), ct(:)
INTEGER :: mtd_steps, md_steps, i, t_min, t_max
INTEGER :: mtd_max, w_cv, w_hill, i_mtd, i_md
INTEGER :: i_s1, i_s2, i_s3, i_s4, nbin1, nbin2, nbin3, nbin4
INTEGER :: index1, index2, index3, index4

REAL*8, PARAMETER :: kb=1.9872041E-3 !kcal K-1 mol-1
REAL*8, PARAMETER :: kj_to_kcal = 0.239006

OPEN(1,FILE='input',STATUS='old')
OPEN(2,FILE='PROB_2D',STATUS='replace')
OPEN(11,FILE='COLVAR',STATUS='old')
OPEN(12,FILE='HILLS',STATUS='old')
OPEN(21,file='data_ct.dat',status='old')
OPEN(22,file='data_vbias.dat',status='old')

CALL get_steps(11,md_steps)
CALL get_steps(12,mtd_steps)

!print *, 'md_steps=', md_steps, 'mtd_steps=', mtd_steps

read(1,*)  T, bias_fact
read(1,*) t_min, t_max

IF(t_max.gt.md_steps)STOP '!!ERROR: t_max > total MD steps'

read(1,*) gridmin1, gridmax1, griddiff1
read(1,*) gridmin2, gridmax2, griddiff2
read(1,*) gridmin3, gridmax3, griddiff3
read(1,*) gridmin4, gridmax4, griddiff4
read(1,*) w_cv, w_hill

! Keeping no of steps as maximum steps mentioned
md_steps = t_max

 deltaT = (bias_fact - 1.d0)*T
 alpha  = (T + deltaT)/deltaT

 kbT = kb*T
 ktb = kbT*bias_fact

WRITE(*,'(A,I10)')'No: of MTD steps        =',mtd_steps
WRITE(*,'(A,I10)')'No: of MD  steps        =',md_steps
WRITE(*,'(A,F9.2)')'Physical Temp (K)      =',T
WRITE(*,'(A,F9.2)')'CV Temp (K)            =',T
WRITE(*,'(A,F9.2)')'Bias Factor (K)        =',bias_fact
WRITE(*,'(A,I10)')'Print Freq. cvmdck_mtd  =',w_cv
WRITE(*,'(A,I10)')'Freq. of Hill Update    =',w_hill
WRITE(*,'(A,I10)')'Reweigtht: Min step     =',t_min
WRITE(*,'(A,I10)')'Reweigtht: Max step     =',t_max
WRITE(*,'(A,F9.2)')'DeltaT      (K)        =',deltaT
WRITE(*,'(A,F9.2)')'Alpha value            =',alpha

ALLOCATE(cv1(md_steps),cv2(md_steps))
ALLOCATE(cv3(md_steps),cv4(md_steps))
ALLOCATE(vbias(md_steps),ct(mtd_steps))

DO i_md=1,md_steps
 READ(11,*) dum,cv1(i_md),cv2(i_md),cv3(i_md),cv4(i_md)
     IF( cv1(i_md) .gt.  3.14d0)  cv1(i_md) = cv1(i_md) - 6.28d0
     IF( cv1(i_md) .lt. -3.14d0 ) cv1(i_md) = cv1(i_md) + 6.28d0
     IF( cv2(i_md) .gt.  3.14d0)  cv2(i_md) = cv2(i_md) - 6.28d0
     IF( cv2(i_md) .lt. -3.14d0 ) cv2(i_md) = cv2(i_md) + 6.28d0
     IF( cv3(i_md) .gt.  3.14d0)  cv3(i_md) = cv3(i_md) - 6.28d0
     IF( cv3(i_md) .lt. -3.14d0 ) cv3(i_md) = cv3(i_md) + 6.28d0
     IF( cv4(i_md) .gt.  3.14d0)  cv4(i_md) = cv4(i_md) - 6.28d0
     IF( cv4(i_md) .lt. -3.14d0 ) cv4(i_md) = cv4(i_md) + 6.28d0
END DO

nbin1 = NINT((gridmax1-gridmin1)/griddiff1)+1
nbin2 = NINT((gridmax2-gridmin2)/griddiff2)+1

write(*,*) nbin1, nbin2

write(*,*) "reading vbias.dat file"

do i_md=1,md_steps
  read(22,*) dum, vbias(i_md)
end do

write(*,*) "reading ct.dat file"
do i_mtd=1,mtd_steps
  read(21,*) dum, ct(i_mtd)
end do

ALLOCATE(prob(nbin1,nbin2))

WRITE(*,*) 'calculating  probability'

den=0.d0
prob=0.d0

DO i_md=1,md_steps
 IF((i_md.GT.t_min).AND.(i_md.LT.t_max))THEN
 index1 = nint((cv1(i_md)-gridmin1)/griddiff1) +1
 index2 = nint((cv2(i_md)-gridmin2)/griddiff2) +1

     IF(index1.gt.0.and.index2.gt.0.and.index1.le.nbin1.and.index2.le.nbin2) then

      i_mtd=(i_md*w_cv/w_hill)

      IF(i_mtd == 0) THEN
        dum=0.d0
      ELSE
        dum=vbias(i_md) - ct(i_mtd)
      ENDIF

      prob(index1,index2) = prob(index1,index2) + DEXP(dum/kbT)
      den=den+DEXP(dum/kbT)
     END IF

 END IF
END DO

  dum=den*griddiff1*griddiff2
  den=1.d0/dum

DO i_s1=1,nbin1
s1=DFLOAT(i_s1-1)*griddiff1+gridmin1
   DO i_s2=1,nbin2
   s2=DFLOAT(i_s2-1)*griddiff2+gridmin2

           prob(i_s1,i_s2)=prob(i_s1,i_s2)*den

           WRITE(2,'(E16.8)')s1, s2, prob(i_s1,i_s2)
   END DO
      WRITE(2,*)
END DO
 WRITE(*,'(A)')'Unbiased distribution written in PROB_2D'

close(1)
close(2)
close(11)
close(12)
close(21)
close(22)

DEALLOCATE(cv1, cv2, vbias, ct)
DEALLOCATE(cv3, cv4)
DEALLOCATE(prob)

END PROGRAM
!-------------------------------------------------!
SUBROUTINE get_steps(iunit,nsteps)
IMPLICIT NONE
INTEGER :: iunit, nsteps
INTEGER :: ios
nsteps=0
REWIND(iunit)
  Read_Loop: DO
  READ(iunit,*,IOSTAT=ios)
    IF(ios.ne.0)EXIT Read_Loop
    nsteps=nsteps+1
  END DO Read_Loop
REWIND(iunit)
END SUBROUTINE
!------------------------------------------------------------------!


*     TG01HD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, MMAX, PMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDE, LDQ, LDZ
      PARAMETER        ( LDA = LMAX, LDB = LMAX, LDC = PMAX,
     $                   LDE = LMAX, LDQ = LMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, NMAX, 2*MMAX ) )
*     .. Local Scalars ..
      CHARACTER*1      COMPQ, COMPZ, JOBCO
      INTEGER          I, INFO, J, M, N, NCONT, NIUCON, NRBLCK, P
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      INTEGER          IWORK(MMAX), RTAU(NMAX)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX),
     $                 Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01HD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOBCO
      COMPQ = 'I'
      COMPZ = 'I'
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99987 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99986 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the transformed descriptor system (A-lambda E,B,C).
               CALL TG01HD( JOBCO, COMPQ, COMPZ, N, M, P, A, LDA,
     $                      E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ,
     $                      NCONT, NIUCON, NRBLCK, RTAU, TOL, IWORK,
     $                      DWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99994 ) NCONT, NIUCON
                  WRITE ( NOUT, FMT = 99985 )
                  WRITE ( NOUT, FMT = 99984 ) ( RTAU(I), I = 1,NRBLCK )
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 30 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   30             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 40 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 50 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N )
   50             CONTINUE
                  WRITE ( NOUT, FMT = 99990 )
                  DO 60 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01HD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01HD = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ')
99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (' Dimension of controllable part   =', I5/
     $        ' Number of uncontrollable infinite eigenvalues =', I5)
99993 FORMAT (/' The transformed input/state matrix Q''*B is ')
99992 FORMAT (/' The transformed state/output matrix C*Z is ')
99991 FORMAT (/' The left transformation matrix Q is ')
99990 FORMAT (/' The right transformation matrix Z is ')
99989 FORMAT (/' L is out of range.',/' L = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
99985 FORMAT (/' The staircase form row dimensions are ' )
99984 FORMAT (10I5)
      END


C
C 			Lyon's Cochlear Model, The Program
C 	   			   Malcolm Slaney
C 			     Advanced Technology Group
C 				Apple Computer, Inc.
C 				 malcolm@apple.com
C 				   November 1988
C
C 	This program implements a model of acoustic propagation and detection
C 	in the human cochlea.  This model was first described by Richard F.
C 	Lyon.  Please see
C 		Malcolm Slaney, "Lyon's Cochlear Model, the Mathematica
C 		Notebook," Apple Technical Report #13, 1988
C 	for more information.  This report is available from the Apple
C 	Corporate Library.
C
C 	Warranty Information
C 	Even though Apple has reviewed this software, Apple makes no warranty
C 	or representation, either express or implied, with respect to this
C 	software, its quality, accuracy, merchantability, or fitness for a
C 	particular purpose.  As a result, this software is provided "as is,"
C 	and you, its user, are assuming the entire risk as to its quality
C 	and accuracy.
C
C 	Copyright (c) 1988-1989 by Apple Computer, Inc
C
C  $Header: fcor.f,v 2.2 90/12/17 18:01:01 malcolm Exp $
C
C  $Log:	fcor.f,v $
c Revision 2.2  90/12/17  18:01:01  malcolm
c Removed ALIMIT subroutine definition.
c
c Revision 2.1  89/11/09  23:15:37  malcolm
c Fixed minor problem in the test for zero data in the correlation output.
c
c Revision 2.0  89/07/25  18:58:32  malcolm
c Completely debugged and tested version on the following machines (roughly
c in order of performance):
c Cray, Stellar, SGI, Sun-4, Sequent Balance, Sun-3, VAX, Macintosh under
c both MPW and LightSpeed C.
c
c Revision 1.4  89/07/19  17:01:49  malcolm
c Put autotasking code into comment.  Added alimit routine.  Also changed
c check for 0 to check for less than 1e-10.
c
c Revision 1.1  88/10/23  22:40:39  malcolm
c Initial revision
c
C
C
      subroutine fcor(input, output, window, work, lags, channels,
     1          datalength, fftlength, index, normalize)
      integer lags, datalength, fftlength, channels
      real input(datalength,channels), output(lags, channels)
      real window(datalength), normalize
      complex work(3*fftlength)

      complex fftdata(fftlength+1)
      integer channel, i, j
      real temp, firstreal, secondreal, firstim, secondim
      real firstscale, secondscale
      complex workx(3*fftlength)

      do 1 i=1,3*fftlength
    1   workx(i) = work(i)

c     do 5 i=1,datalength
c       input(i,21) = 1+sin(i*3.14159265/10.0)
c       input(i,22) = 0.0
c       input(i,23) = 1+sin(i*3.14159265/20.0)
c       input(i,24) = 0.0
c   5 continue

C	The CMIC$ directives enable microtasking of the loop.
C CMIC$ DO ALL PRIVATE(workx, fftdata, channel, i, j, temp, firstreal,
C      1               secondreal, firstim, secondim, firstscale,
C      2               secondscale)
CMIC$ DO GLOBAL
      do 100 channel = 1,channels,2
C                                       Fill the data into the fft arrrays
          do 5 i=index+1,datalength
              fftdata(i-index) = cmplx(input(i,channel),
     1                             input(i,channel+1))
    5     continue
          do 10 i=1,index
              fftdata(datalength-index+i) = cmplx(input(i,channel),
     1                            input(i,channel+1))
   10     continue
C                                       Multiply by the window
          do 15 i=1,datalength
              fftdata(i) = fftdata(i) * window(i)
   15     continue
C                                       Zero pad the data
          do 20 i = datalength+1,fftlength
              fftdata(i) = cmplx(0.0,0.0)
   20     continue

          call cfft2(0,1,fftlength,fftdata,workx,fftdata)

          fftdata(fftlength+1) = fftdata(1)

CDIR$ IVDEP
          do 30, i=1,fftlength/2+1
              j = fftlength - i + 2
              firstreal = (real(fftdata(i))+real(fftdata(j)))/2.0
              firstim = (aimag(fftdata(i))-aimag(fftdata(j)))/2.0
              secondreal = (aimag(fftdata(i))+aimag(fftdata(j)))/2.0
              secondim = (real(fftdata(i))-real(fftdata(j)))/2.0

              firstmag = firstreal*firstreal + firstim*firstim
              secondmag = secondreal*secondreal + secondim*secondim

              fftdata(i) = cmplx(firstmag,secondmag)
              fftdata(j) = cmplx(firstmag,secondmag)
  30      continue

          call cfft2(0,-1,fftlength,fftdata,workx,fftdata)

C
C	The extra factor of fftlength is necessary to compensate for the
C	extra factors of N that are in the FFT.  We want to divide it out
C	before we do the normalize.
C
	  do 35 i=1,fftlength
	      fftdata(i) = fftdata(i)/fftlength
  35	  continue

C
C	Now figure out the scaling factor to use.  If the zero lag case is
C	too small or if it is less than the lag=1 and lag=2 case than we
C	we were probably correlating noise so we scale by zero.  Otherwise
C	we divide all terms of the correlation output by the zero lag term
C	raised to the normalize parameter.  The default value of this parameter
C	is .75 so there is some small compression going on.
C
          temp = real(fftdata(1))
          if (temp .le. 1.0e-10 .or.
     1        temp .lt. real(fftdata(2)) .or.
     2        temp .lt. real(fftdata(3))) then
              firstscale = 0.0
          else
	      firstscale = 1.0/(temp**normalize)
          endif

          temp = aimag(fftdata(1))
          if (temp .le. 1.0e-10 .or.
     1        temp .lt. aimag(fftdata(2)) .or.
     2        temp .lt. aimag(fftdata(3))) then
              secondscale = 0.0
          else
	      secondscale = 1.0/(temp**normalize)
          endif

C	Just for testing....
C         firstscale = 1.0
C         secondscale = 1.0
C
          do 40 i=1,lags
              output(i,channel) = real(fftdata(i)) * firstscale
              output(i,channel+1) = aimag(fftdata(i)) * secondscale
   40     continue
  100 continue

      return
      end

      function amax(array,n)
      integer i, n
      real array(n), amax
      i = ismax(n,array,1)
      amax = array(i)
      return
      end

      function amin(array,n)
      integer i, n
      real array(n), amin
      i = ismin(n,array,1)
      amin = array(i)
      return
      end

C
C	Simple vector move subroutine in fortran so that it will vectorize
C	on the Cray.
C
      subroutine vmov(source,sstride,n,dest,dstride)
      real source(*), dest(*)
      integer sstride, n, dstride
      integer i

      do 10 i=0,n-1
	 dest(i*dstride+1) = source(i*sstride+1)
   10 continue

      return
      end


***********************************************************************
* H1 2006 DPDF Fits parameterization                                  *
* ----------------------------------                                  *
* Reference: H1 Collaboration, A. Aktas et al., "Measurement and QCD  *
* Analysis of the Diffractive Deep-Inelastic Scattering Cross Section *
* at HERA", DESY06-049, hep-ex/0606004, subm. to Eur.Phys.J           *
*                                                                     *
* Contact persons in case of questions:                               *
* Frank-Peter Schilling (frank-peter.schilling@cern.ch)               *
* Paul Newman (newmanpr@mail.desy.de)                                 *
* ------------------------------------------------------------------- *
* This routine returns the pomeron or reggeon flux factors            *
* f_{IP,IR/p}(xpom,t)                                                 *
* Both IP and IR flux factors are normalized such that xpom*flux=1    *
* at xpom=0.003; In addition, the IR flux is multiplied by a further  *
* normalization parameter as determined in the fit to the data        *
* The routine returns either the flux at fixed values (xpom,t), or    *
* the t-integrated flux (integrated from t to tmin)                   *
* ------------------------------------------------------------------- *
* Input:  xpom:  xpomeron value                                       *
*         t:     t value (negative!)                                  *
*         int:   0: flux at (xpom,t) is returned                      *
*                1: t-integrated (t...tmin) flux at xpom is returned  *
*         ifit:  1: Fit A  2: Fit B                                   *
*         ipom:  1: Pomeron flux 2: Reggeon flux                      *
* Output: flux:  flux value                                           *
***********************************************************************

      subroutine h12006flux(xpom,t,int,ifit,ipom,flux)

      implicit none

      integer int,ifit,ipom
      double precision xpom,t,a0,ap,b0,c,flux,norm,dm

      if ((ipom.lt.1).or.(ipom.gt.2)) then
         print *,'[H12006FLUX] Unknown ipom: ',ipom
         stop
      endif
      if ((ifit.lt.1).or.(ifit.gt.2)) then
         print *,'[H12006FLUX] Unknown ifit: ',ifit
         stop
      endif

cc JVY : "local" fix - set default value to avoid compiler's complain of uninit variable
      c = -1.d0
      if (ipom.eq.1) then ! pomeron
        if (ifit.eq.1) then ! fit a
          a0 = 1.1182d0
        elseif (ifit.eq.2) then ! fit b
          a0 = 1.1110d0
        endif
        ap = 0.06d0
        b0 = 5.5d0
        c = 1.0d0

      else ! meson
        a0 = 0.5d0
        ap = 0.3d0
        b0 = 1.6d0
        if (ifit.eq.1) then ! fit a
          c = 0.001697d0
        elseif (ifit.eq.2) then ! fit b
          c = 0.001398d0
        endif
      endif

c     normalization
      call rflux2006(0.003d0,a0,ap,b0,-1.d0,1.0d0,1,dm)
      norm=(1./(0.003d0*dm))*c

c     actual flux
      call rflux2006(xpom,a0,ap,b0,t,norm,int,flux)

      return
      end

*******************************************************************************

      subroutine rflux2006(x_pom,a0,ap,b0,tcut,c,int,fl)

      implicit none

      double precision x_pom,a0,tmin,tcut,ap,b0,c,fl,b
      integer int

c     calc min. kinematically  allowed t
      tmin= -(0.93827231D0*x_pom)**2/(1.D0-x_pom)

c     c*xpom**(-(2apom-1))
      fl = c * dexp((2.0d0*a0-1.)*dlog(1.0d0/x_pom))
      b=(b0+2.0d0*ap*dlog(1.0d0/x_pom))

      if (int.eq.0) then
c       at fixed t:  exp(Bt)
        fl = fl * dexp(b*tcut)
      else
c       t integrated: (1/B)*[exp(-B*tmax)-exp(-B*tmin)]
        fl = fl * (dexp(tmin*b)-dexp(tcut*b))/b
      endif

      return
      end


module ab
!Setup A and b i.e. we are solving Ax=b

use gauss_legendre
use inputs
use bonn
implicit none

	!n_k = Number of y_p/W_p nodes. See Eq.15 of T matrix rev. report.
	integer, parameter, public :: n_k = n_0_2q + n_2q_inf

	!ss = Length of xi vector.
	integer, parameter, public :: ss = n_theta_k*(1 + n_k)

	!m_avg = Used in the denomenator of the scatering equation.
	!	i.e. E_q - E_k + i*epsilon ---> sqrt( m_avg^2 + q^2 ) - (m_avg^2 + k^2) + i*epsilon
	real(8), parameter, public :: m_avg = ( m_1 + m_2 )/2.0d0

contains

real(8) function V_pip(q,theta,qp,thetap,lambda1p,lambda2p,lambda1,lambda2,T)
!Computes the phi integrated potential over the interval [0,2*pi].
!See R.A. Rice and Y.E. Kim, Few-Body Systems 14,127-148 (1993)

implicit none

	!T = Isospin
	!(q,theta,phi),(qp,thetap,phip) = vec{q},vec{q'} momentum variables.
	!lambda1p,lambda2p,lambda1,lambda2 = < | >,< |sigma^(1)*sigma^(2)| >
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap,lambda1p,lambda2p,lambda1,lambda2

	!s = Summing variable in the integral approximation
	!c1 = Counter
	!x,w = Nodes and weights for quadrature
	complex(8) :: s
	integer :: c1
	real(8), dimension(n_V_avg) :: x,w

	call gauss_legendre_quadrature(n_V_avg,0.0d0,2.0d0*pi,x,w)

	s = (0.0d0,0.0d0)
	do c1 = 1,n_V_avg

		!phi = 0 in the potential
		s = s + w(c1)*V(q,theta,0.0d0,qp,thetap,x(c1),lambda1p,lambda2p,lambda1,lambda2,T)

	enddo

	!The imaginary part is zero.
	V_pip = ( 1.0d0/(2.0d0*pi) )*real(s)

end function

real(8) function V_1(q,theta,qp,thetap,T)
!<++|V|++>

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V_1 = V_pip(q,theta,qp,thetap,0.5d0,0.5d0,0.5d0,0.5d0,T)

end function

real(8) function V_2(q,theta,qp,thetap,T)
!<++|V|-->

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V_2 = V_pip(q,theta,qp,thetap,0.5d0,0.5d0,-0.5d0,-0.5d0,T)

end function

real(8) function V_3(q,theta,qp,thetap,T)
!<+-|V|+->

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V_3 = V_pip(q,theta,qp,thetap,0.5d0,-0.5d0,0.5d0,-0.5d0,T)

end function

real(8) function V_4(q,theta,qp,thetap,T)
!<+-|V|-+>

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V_4 = V_pip(q,theta,qp,thetap,0.5d0,-0.5d0,-0.5d0,0.5d0,T)

end function

real(8) function V_5(q,theta,qp,thetap,T)
!<++|V|+->

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V_5 = V_pip(q,theta,qp,thetap,0.5d0,0.5d0,0.5d0,-0.5d0,T)

end function

real(8) function V_6(q,theta,qp,thetap,T)
!<+-|V|++>

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V_6 = V_pip(q,theta,qp,thetap,0.5d0,-0.5d0,0.5d0,0.5d0,T)

end function

real(8) function V0(q,theta,qp,thetap,T)
!^{0}V

implicit none

	!See V_phi_int()
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V0 = V_1(q,theta,qp,thetap,T) - V_2(q,theta,qp,thetap,T)

end function

real(8) function V1(q,theta,qp,thetap,T)
!^{1}V

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V1 = V_3(q,theta,qp,thetap,T) + V_4(q,theta,qp,thetap,T)

end function

real(8) function V12(q,theta,qp,thetap,T)
!^{12}V

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V12 = V_1(q,theta,qp,thetap,T) + V_2(q,theta,qp,thetap,T)

end function

real(8) function V34(q,theta,qp,thetap,T)
!^{34}V

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V34 = V_3(q,theta,qp,thetap,T) - V_4(q,theta,qp,thetap,T)

end function

real(8) function V55(q,theta,qp,thetap,T)
!^{55}V

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V55 = 2.0d0*V_5(q,theta,qp,thetap,T)

end function

real(8) function V66(q,theta,qp,thetap,T)
!^{66}V

implicit none

	!See V_pip
	integer, intent(in) :: T
	real(8), intent(in) :: q,theta,qp,thetap

	V66 = 2.0d0*V_6(q,theta,qp,thetap,T)

end function

subroutine principle_value_quadrature(q,xx,ww)
!Generates quadradure rule to preform the priciple value integral i.e.:
!	pv int[f(x)/(x-q),{x,0,inf}] where f(x) has a singularity at x=q.
!To preform the principle value integral:
!	pv int[f(x)/(x-q),{x,0,inf}] = int[f(x)/(x-q),{x,0,2q}] + int[f(x)/(x-q),{x,2q,inf}]
!	Then employ Gauss-Legendre quadrature normally with the exception that
!	YOU MAKE SURE TO CHOOSE AN EVEN NUMBER OF PONTS FOR THE [0,2q] INTEGRAL.

implicit none

	!q = Momentum variable
	!xx,ww = Nodes/Weights
	real(8), intent(in) :: q
	real(8), dimension(n_k), intent(out) :: xx,ww

	!x_1,w_1 = Nodes/weights for [0,2q] integral.
	!x_2,w_2 = Nodes/weights for [2q,inf] integral.
	real(8), dimension(n_0_2q) :: x_1,w_1
	real(8), dimension(n_2q_inf) :: x_2,w_2

	call gauss_legendre_quadrature(n_0_2q,0.0d0,2.0d0*q,x_1,w_1)
	call gauss_legendre_quadrature(n_2q_inf,2.0d0*q,cutoff_inf,x_2,w_2)

	xx(1:n_0_2q) = x_1
	xx(n_0_2q + 1:n_k) = x_2
	ww(1:n_0_2q) = w_1
	ww(n_0_2q + 1:n_k) = w_2

end subroutine

subroutine xi(q,xi_k)
!Produces the xi_k(q) vector found in Eq. 19 of T matrix report.

implicit none

	!q = Momentum variable
	!xi_k = Xi vector appearing in Eq. 19 of T matirx report.
	real(8), intent(in) :: q
	real(8), dimension(ss,2), intent(out) :: xi_k

	!c1,c2 = Counters
	!p,j = Variables in Eq. 18 of T matrix report.
	!x_theta_k, w_theta_k,x_k,w_k = Nodes and weights for the theta_k, and k integral.
	integer :: c1,c2,p,j
	real(8), dimension(n_theta_k) :: x_theta_k,w_theta_k
	real(8), dimension(n_k) :: x_k,w_k

	call gauss_legendre_quadrature(n_theta_k,0.0d0,pi,x_theta_k,w_theta_k)
	call principle_value_quadrature(q,x_k,w_k)

	!c_j(q) vector see Eq. 19 of T matrix report.
	do c1 = 1,n_theta_k

		xi_k(c1,1) = q
		xi_k(c1,2) = x_theta_k(c1)

	enddo

	!b_l vector see Eq. 19 of T matrix report.
	do c2 = 1,n_k*n_theta_k

		p = floor(  ( dble(c2-1)/dble(n_theta_k) ) + 1.0d0  )
		j = c2 - n_theta_k*(p - 1)

		xi_k(c2 + n_theta_k,1) = x_k(p)
		xi_k(c2 + n_theta_k,2) = x_theta_k(j)

	enddo

end subroutine

real(8) function pauli(qpp,thetapp)
!The Pauli operator i.e. Q(q",theta",P,kF)
!
!Notes:
!	Pcm, k_fermi, and Q_pauli are globaly defined variables found in input.f90

implicit none

	!qpp,thetapp = Momentum variables. I sometimes refere to vec{k} as vec{q}".
	real(8), intent(in) :: qpp,thetapp

	!Temporary variables
	real(8) :: temp1,temp2

	temp1 = dsqrt(  (qpp**2.0d0) + (Pcm**2.0d0) + 2.0d0*Pcm*qpp*dcos(thetapp)  )
	temp2 = dsqrt(  (qpp**2.0d0) + (Pcm**2.0d0) - 2.0d0*Pcm*qpp*dcos(thetapp)  )

	!I have to convert kF[fm^(-1)] to MeV by multiplying by hbar*c.
	if( (temp1 > (k_fermi*197.327d0)) .and. (temp2 > (k_fermi*197.327d0)) ) then

		pauli = 1.0d0

	else

		pauli = Q_pauli

	endif

end function

complex(8) function alpha(k,j,q,T,Vn)
!Computes alpha

implicit none

	interface

		real(8) function Vn(q,theta,qp,thetap,T)

			integer, intent(in) :: T
			real(8), intent(in) :: q,theta,qp,thetap

		end function

	end interface

	!k,j = Row,Column of matrix.
	!T = Isospin.
	!q = Momentum variable.
	integer, intent(in) :: k,j,T
	real(8), intent(in) :: q

	!E_q = I.e. E_q = sqrt( q^2 + m_avg^2 ).
	!x_theta_k, w_theta_k = Nodes and weights for the theta_k integral.
	!	See Eq. 3 of T matrix report.
	!xi_k = Values to evaluate vec{q'} at. See Eq. 20 of T matrix rev. report.
	real(8) :: E_q
	real(8), dimension(n_theta_k) :: x_theta_k,w_theta_k
	real(8), dimension(ss,2):: xi_k

	call xi(q,xi_k)

	call gauss_legendre_quadrature(n_theta_k,0.0d0,pi,x_theta_k,w_theta_k)

	!Use "m_avg" i.e. not m or m_1 or m_2.
	E_q = dsqrt( q**2.0d0 + m_avg**2.0d0 )

	alpha = -i*(pi**2.0d0)*q*E_q*w_theta_k(j)*dsin( x_theta_k(j) )*Vn(q,x_theta_k(j),xi_k(k,1),xi_k(k,2),T)*pauli(q,x_theta_k(j))

end function

real(8) function beta(k,L,q,T,Vn)
!Computes beta

implicit none

	interface

		real(8) function Vn(q,theta,qp,thetap,T)

			integer, intent(in) :: T
			real(8), intent(in) :: q,theta,qp,thetap

		end function

	end interface

	!k,L = Row,Column of matrix.
	!T = Isospin.
	!q = Momentum variable.
	integer, intent(in) :: k,L,T
	real(8), intent(in) :: q

	!p,j = Variables in Eq. 18 of T matrix report.
	!E_q,E_yp = I.e. E_q = sqrt(m_avg^2 + q^2).
	!temp1 = Temporary variable.
	!x_theta_k, w_theta_k,x_k,w_k = Nodes and weights for the theta_k, and k integral.
	!	See Eq. 3 of T matrix report.
	integer :: p,j
	real(8) :: E_q,E_yp,temp1
	real(8), dimension(n_theta_k) :: x_theta_k,w_theta_k
	real(8), dimension(n_k) :: x_k,w_k
	real(8), dimension(ss,2):: xi_k

	call xi(q,xi_k)

	call gauss_legendre_quadrature(n_theta_k,0.0d0,pi,x_theta_k,w_theta_k)
	call principle_value_quadrature(q,x_k,w_k)

	p = floor(  ( dble(L-1)/dble(n_theta_k) ) + 1.0d0  )
	j = L - n_theta_k*(p - 1)

	!Use "m_avg" i.e. not m or m_1 or m_2.
	E_q = dsqrt( q**2.0d0 + m_avg**2.0d0 )
	E_yp = dsqrt(  ( x_k(p) )**2.0d0 + m_avg**2.0d0  )

	temp1 = ( x_k(p)**2.0d0 )*dsin( x_theta_k(j) )
	beta = pi*w_k(p)*w_theta_k(j)*( temp1/(E_q - E_yp) )*Vn(x_k(p),x_theta_k(j),xi_k(k,1),xi_k(k,2),T)*pauli(x_k(p),x_theta_k(j))

end function

subroutine build_A(A,q,T,Vn)
!Computes matrix A i.e. Ax=b

implicit none

	interface

		real(8) function Vn(q,theta,qp,thetap,T)

			integer, intent(in) :: T
			real(8), intent(in) :: q,theta,qp,thetap

		end function

	end interface

	!T = Isospin.
	!q = Momentum variable.
	!A = Matrix in Eq. 23 of T matrix report.
	integer, intent(in) :: T
	real(8), intent(in) :: q
	complex, dimension(ss,ss), intent(out) :: A

	!c1,c2,c3,c4 = Counters
	integer :: c1,c2,c3,c4

	!Put column on the outside of loop. Since this is more efficient in fortran.

!$omp parallel
!$omp do

	!Alpha block
	do c2 = 1,n_theta_k

		do c1 = 1,ss

			!They are automatically typecast
			A(c1,c2) = alpha(c1,c2,q,T,Vn)

		enddo

	enddo

!$omp end do
!$omp do

	!Beta block
	do c4 = 1,(n_k*n_theta_k)

		do c3 = 1,ss

			!They are automatically typecast
			A(c3,n_theta_k + c4) = beta(c3,c4,q,T,Vn)

		enddo

	enddo

!$omp end do
!$omp end parallel

end subroutine

subroutine build_V(V,q,T,Vn)
!Builds the potential vector. i.e. the b in Ax=b

implicit none

	interface

		real(8) function Vn(q,theta,qp,thetap,T)

			integer, intent(in) :: T
			real(8), intent(in) :: q,theta,qp,thetap

		end function

	end interface

	!q= Momentum variable
	!T = Isospin
	!V = Potential vector
	real(8), intent(in) :: q
	integer, intent(in) :: T
	complex, dimension(ss,n_theta), intent(out) :: V

	!c1 = Counter
	!xi_k = See Eq. 19 of T matrix report.
	!x,w = Nodes/Weights
	integer :: c1,c2
	real(8), dimension(ss,2) :: xi_k
	real(8), dimension(n_theta) :: x,w

	call xi(q,xi_k)
	call gauss_legendre_quadrature(n_theta,0.0d0,pi,x,w)

	!Put column on the outside of loop. Since this is more efficient in fortran.
	do c2 = 1,n_theta

		do c1 = 1,ss

			!They are automatically typecast
			V(c1,c2) = Vn(q,x(c2),xi_k(c1,1),xi_k(c1,2),T)

		enddo

	enddo

end subroutine

end module