!-----------------------------------------------------------------
! This module computes the solution of a sparse
! symmetric/unsymmetric linear system : Ax = b
! A is a sparse matrix
!-----------------------------------------------------------------
! This module comes from Quantsolver project
!
! Julien Versaci
!-----------------------------------------------------------------

module linearSystemSolver
implicit none

!..     Internal solver memory pointer
!        INTEGER*8 pt(64)

!..     All other variables
!        INTEGER maxfct, mnum, mtype, phase, nrhs, error, msglvl
!        INTEGER iparm(64)
!        REAL*8  dparm(64)

!        INTEGER i, j, idum, solver
!        REAL*8  waltime1, waltime2, ddum, normb, normr

!        DATA  nrhs /1/, maxfct /1/, mnum /1/

! External Subroutines ..
      EXTERNAL         SGESV

contains

!.. ----------------------------------------------------------------
!.. unsymmetric linear system
!.. ----------------------------------------------------------------

!        subroutine unsymmetric_linear_solver(a,ia,ja,b,x,Nt)
!        REAL*8 :: a(:)
!        REAL*8 :: b(:)
!        REAL*8 :: x(:)
!        INTEGER :: ia(:)
!        INTEGER :: ja(:)
!        INTEGER :: Nt

!  .. Setup Pardiso control parameters und initialize the solvers
!     internal adress pointers. This is only necessary for the FIRST
!     call of the PARDISO solver.
!
!      mtype     = 11      ! unsymmetric matrix
!      solver    = 10     ! use sparse direct method

!      call pardisoinit(pt, mtype, solver, iparm, dparm, error)

!  .. Numbers of Processors ( value of OMP_NUM_THREADS )
!      iparm(3) = 1

!..   Reordering and Symbolic Factorization, This step also allocates
!     all memory that is necessary for the factorization
!
!      phase     = 11      ! only reordering and symbolic factorization
!      msglvl    = 1       ! with statistical information

!      CALL pardiso (pt, maxfct, mnum, mtype, phase, Nt, a, ia, ja, idum, nrhs, iparm, msglvl, ddum, ddum, error,dparm)

!      WRITE(*,*) 'Reordering completed ... '

!      IF (error .NE. 0) THEN
!        WRITE(*,*) 'The following ERROR was detected: ', error
!        STOP
!      END IF

!      WRITE(*,*) 'Number of nonzeros in factors   = ',iparm(18)
!      WRITE(*,*) 'Number of factorization MFLOPS  = ',iparm(19)

!.. Factorization.
!      phase     = 22  ! only factorization
!      CALL pardiso (pt, maxfct, mnum, mtype, phase, Nt, a, ia, ja, idum, nrhs, iparm, msglvl, ddum, ddum, error,dparm)

!      WRITE(*,*) 'Factorization completed ...  '
!      IF (error .NE. 0) THEN
!         WRITE(*,*) 'The following ERROR was detected: ', error
!        STOP
!      ENDIF

!.. Back substitution and iterative refinement
!      phase     = 33  ! only solve
!      iparm(8)  = 1   ! max numbers of iterative refinement steps

!      CALL pardiso (pt, maxfct, mnum, mtype, phase, Nt, a, ia, ja, idum, nrhs, iparm, msglvl, b, x, error, dparm)
!      WRITE(*,*) 'Solve completed ... '
!
!      WRITE(*,*) 'The solution of the system is '
!      DO i = 1, Nt
!        WRITE(*,*) ' x(',i,') = ', x(i)
!      END DO

!.. Back substitution and solution with A^Tx=b  and iterative refinement
!     phase     = 33  ! only solve
!      iparm(8)  = 1   ! max numbers of iterative refinement steps
!      iparm(12) = 1   ! Solving with transpose matrix
!      do i = 1, Nt
!        b(i) = 1.d0
!      end do
!
!      CALL pardiso (pt, maxfct, mnum, mtype, phase, Nt, a, ia, ja, idum, nrhs, iparm, msglvl, b, x, error, dparm)
!      WRITE(*,*) 'Solve completed ... '

!      WRITE(*,*) 'The solution of the system is '
!      DO i = 1, Nt
!        WRITE(*,*) ' x(',i,') = ', x(i)
!      END DO

!.. Termination and release of memory
!      phase     = -1           ! release internal memory
!      CALL pardiso (pt, maxfct, mnum, mtype, phase, Nt, ddum, idum, idum, idum, nrhs, iparm, msglvl, ddum, ddum, error, dparm)

! end subroutine

subroutine lapack_solver(matrix,cl_tab,Nt,NRHS)
      ! Parameters ..
      INTEGER, INTENT(IN) :: NRHS, Nt
      REAL :: matrix(:,:)
      REAL :: cl_tab(:)
      INTEGER :: LDA , LDB
      ! local scalar
      INTEGER ::  INFO
      ! local array
      INTEGER :: IPIV(Nt)

     LDA = Nt
     LDB = Nt

!
!     Solve the equations A*X = B.
!
      CALL SGESV( Nt, NRHS, matrix, LDA, IPIV, cl_tab, LDB, INFO )

end subroutine

subroutine  gaussJordanMethod(matrix,cl_tab,Nt)
          INTEGER :: i,j
          INTEGER :: k,r,p
          REAL :: max_,tmp,tmp2,pivot
          INTEGER, INTENT(IN) :: Nt
          REAL :: matrix(:,:)
          REAL :: cl_tab(:)

          r=0 ! Initialization of the pivot row

        do j=1,Nt ! loop of all column
           max_ = 0.0

           !step one, find the largest value of the row j

           do i=r+1,Nt ! loop of the row j to find the max

               if ( abs(matrix(i,j)) > abs(max_) ) then
               max_ = matrix(i,j)
               k=i
               end if
           end do

           ! step two, pivoting 1
           ! find a row with the largest pivoting element

           if ( max_ /= 0) then
           r=r+1
           matrix(k,:) = matrix(k,:)/max_
            cl_tab(k) =  cl_tab(k)/max_

            do p=1,Nt
            tmp = matrix(k,p)
            matrix(k,p) = matrix(r,p)
            matrix(r,p) = tmp
            end do

            tmp2 =  cl_tab(k)
             cl_tab(k) = cl_tab(r)
             cl_tab(r) =tmp2

           do i=1,Nt
             if (i /= r) then
             pivot = matrix(i,j)
             matrix(i,:) = matrix(i,:) - pivot*matrix(r,:)
              cl_tab(i) =  cl_tab(i) -  pivot* cl_tab(r)

            end if
           end do
         end if
       end do

end subroutine

end module


!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
!
!    NEMO - Numerical Engine (for) Multiphysics Operators
! Copyright (c) 2007, Stefano Toninel
!                     Gian Marco Bianchi  University of Bologna
!              David P. Schmidt    University of Massachusetts - Amherst
!              Salvatore Filippone University of Rome Tor Vergata
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
!     1. Redistributions of source code must retain the above copyright notice,
!        this list of conditions and the following disclaimer.
!     2. Redistributions in binary form must reproduce the above copyright notice,
!        this list of conditions and the following disclaimer in the documentation
!        and/or other materials provided with the distribution.
!     3. Neither the name of the NEMO project nor the names of its contributors
!        may be used to endorse or promote products derived from this software
!        without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
! ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!---------------------------------------------------------------------------------
!

!

SUBMODULE (tools_math) pwl_implementation
    IMPLICIT NONE
    !! author: sfilippo
    !! date: 2008-04-22 14:51:09

    CONTAINS

        MODULE PROCEDURE pwl_interp_x_s
        USE class_psblas, ONLY : psb_dpk_, abort_psblas
        USE tools_math, ONLY : pwl_nearest
        IMPLICIT NONE
        !! Description:
        !!    Piecewise linear interpolation for a x-y data series.
        !!    Type REAL, rank = 0
        !!
        INTEGER :: i1, i2
        REAL(psb_dpk_) :: dx, dy, m

        IF(SIZE(x_data) /= SIZE(y_data)) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        CALL pwl_nearest(x,x_data,i1,i2)

        IF(x == x_data(i1)) THEN
            y = y_data(i1)
        ELSE
            dx = x_data(i2) - x_data(i1)
            dy = y_data(i2) - y_data(i1)
            m = dy / dx

            y = y_data(i1) + m * (x - x_data(i1))
        END IF

100     FORMAT(' ERROR! Array size mismatch in PWL_INTERP_X_S')

        END PROCEDURE pwl_interp_x_s

        MODULE PROCEDURE pwl_interp_x_v
        USE class_psblas, ONLY : psb_dpk_, abort_psblas
        USE tools_math, ONLY : pwl_nearest
        IMPLICIT NONE
        !! Description:
        !!    Piecewise linear interpolation for a x-y data series.
        !!    Type REAL, rank = 1
        !!
        INTEGER :: i1, i2
        REAL(psb_dpk_) :: dx
        REAL(psb_dpk_), DIMENSION(SIZE(y)) :: dy, m

        IF(    SIZE(x_data) /= SIZE(y_data,2) .OR. &
            & SIZE(y)      /= SIZE(y_data,1)) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        CALL pwl_nearest(x,x_data,i1,i2)

        IF(x == x_data(i1)) THEN
            y(:) = y_data(:,i1)
        ELSE
            dx = x_data(i2) - x_data(i1)
            dy(:) = y_data(:,i2) - y_data(:,i1)

            m = dy / dx

            y = y_data(:,i1) + m * (x - x_data(i1))
        END IF

100     FORMAT(' ERROR! Array size mismatch in PWL_INTERP_X_V')

        END PROCEDURE pwl_interp_x_v

        MODULE PROCEDURE pwl_interp_x_vec
        USE class_psblas, ONLY : psb_dpk_, abort_psblas
        USE class_vector, ONLY : vector, OPERATOR(*), OPERATOR(+), OPERATOR(-)
        USE tools_math, ONLY : pwl_nearest
        IMPLICIT NONE
        !! Description:
        !!    Piecewise linear interpolation for a x-y data series.
        !!    Type VECTOR, rank = 1
        !!
        INTEGER :: i1, i2
        REAL(psb_dpk_) :: dx
        TYPE(vector) :: dy, m

        IF(SIZE(x_data) /= SIZE(y_data)) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        CALL pwl_nearest(x,x_data,i1,i2)

        IF(x_data(i1) == x) THEN
            y = y_data(i1)
        ELSE
            dx = x_data(i2) - x_data(i1)
            dy = y_data(i2) - y_data(i1)

            m = (1.d0 / dx) * dy

            y = y_data(i1) + (x - x_data(i1)) * m
        END IF

100     FORMAT(' ERROR! Array size mismatch in PWL_INTERP_X_VEC')

        END PROCEDURE pwl_interp_x_vec

        MODULE PROCEDURE pwl_nearest
        USE class_psblas, ONLY : abort_psblas
        IMPLICIT NONE
        !! $Id: pwl_nearest.f90 3093 2008-04-22 14:51:09Z sfilippo $
        !!
        !! Description:
        !!    Given an array X_DATA and a scalar X returns the subscripts of the two
        !!    nearest elements in the data series.
        !!
        INTEGER :: i, n

        n = SIZE(x_data)

        IF(x < x_data(1)) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        i = 1
        DO
            IF(x < x_data(i)) EXIT
            i = i + 1
            IF(i > n) EXIT
        END DO

        IF(i <= n) THEN
            i1 = i - 1
            i2 = i
        ELSE
            i1 = n - 1
            i2 = n
        END IF

100     FORMAT(' ERROR! Illegal entry in PWL_NEAREST')

        END PROCEDURE pwl_nearest

        MODULE PROCEDURE pwl_interp_dx_s
        USE class_psblas, ONLY : psb_dpk_
        IMPLICIT NONE
        !! Description:
        !!    Piecewise linear interpolation for a set of equally spaced data.
        !!    Type REAL, rank = 0
        !!
        INTEGER :: i1, i2
        REAL(psb_dpk_) :: dx_inv, slope, x1, xrel

        dx_inv = 1.d0 / dx

        xrel = (x - xmin) * dx_inv

        i1 = FLOOR(xrel) + 1
        i2 = CEILING(xrel) + 1

        slope = (y_data(i2) - y_data(i1)) * dx_inv

        x1 = xmin + dx * (i1 - 1)

        y = y_data(i1) + slope * (x - x1)

        END PROCEDURE pwl_interp_dx_s

        MODULE PROCEDURE pwl_interp_dx_v
        USE class_psblas, ONLY : psb_dpk_, abort_psblas
        IMPLICIT NONE
        !! Description:
        !!    Piecewise linear interpolation for a set of equally spaced data.
        !!    Type REAL, rank = 1
        !!
        INTEGER :: i, i1, i2, n
        REAL(psb_dpk_) :: dx_inv, slope, x1, xrel

        IF(SIZE(y) /= SIZE(x)) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        dx_inv = 1.d0 / dx

        n = SIZE(x)

        DO i = 1, n
            xrel = (x(i) - xmin) * dx_inv

            i1 = FLOOR(xrel) + 1
            i2 = CEILING(xrel) + 1

            slope = (y_data(i2) - y_data(i1)) * dx_inv

            x1 = xmin + dx * (i1 - 1)

            y(i) = y_data(i1) + slope * (x(i) - x1)
        END DO

100     FORMAT(' ERROR! Size mismatch in PWL_INTERP_DX_V')

        END PROCEDURE pwl_interp_dx_v

        MODULE PROCEDURE pwl_deriv_x_s
        USE class_psblas, ONLY : abort_psblas
        USE tools_math, ONLY : pwl_nearest

        IMPLICIT NONE
        !! $Id: pwl_deriv_x.f90 3093 2008-04-22 14:51:09Z sfilippo $
        !!
        !! Description:
        !!    Compute the first derivative of a piecewise linear x-y data series.
        !!    Type REAL, rank = 0
        !!
        INTEGER :: i1, i2

        IF(SIZE(x_data) /= SIZE(y_data)) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        CALL pwl_nearest(x,x_data,i1,i2)

        dydx = (y_data(i2) - y_data(i1)) / (x_data(i2) - x_data(i1))

100     FORMAT(' ERROR! Array size mismatch in PWL_DERIV_X_S')

        END PROCEDURE pwl_deriv_x_s

        MODULE PROCEDURE pwl_deriv_x_v
        USE class_psblas, ONLY : abort_psblas
        USE tools_math, ONLY : pwl_nearest
        IMPLICIT NONE
        !! Description:
        !!    Compute the first derivative of a piecewise linear x-y data series.
        !!    Type REAL, rank = 1
        !!
        INTEGER :: i1, i2

        IF(    SIZE(x_data) /= SIZE(y_data,2) .OR. &
            & SIZE(dydx)   /= SIZE(y_data,1)) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        CALL pwl_nearest(x,x_data,i1,i2)

        dydx = (y_data(:,i2) - y_data(:,i1)) / (x_data(i2) - x_data(i1))

100     FORMAT(' ERROR! Array size mismatch in PWL_DERIV_X_V')

        END PROCEDURE pwl_deriv_x_v

        MODULE PROCEDURE pwl_deriv_x_vec
        USE class_psblas, ONLY : psb_dpk_, abort_psblas
        USE tools_math, ONLY : pwl_nearest
        USE class_vector, ONLY : OPERATOR(*), OPERATOR(-)
        IMPLICIT NONE
        !! Description:
        !!    Compute the first derivative of a piecewise linear x-y data series.
        !!    Type VECTOR, rank = 0
        !!
        INTEGER :: i1, i2
        REAL(psb_dpk_) :: dx

        IF(SIZE(x_data) /= SIZE(y_data)) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        CALL pwl_nearest(x,x_data,i1,i2)

        dx = x_data(i2) - x_data(i1)
        dydx = (1.d0 / dx) * (y_data(i2) - y_data(i1))

100     FORMAT(' ERROR! Array size mismatch in PWL_DERIV_X_VEC')
        ! REMARK! It returns the right derivative!
        END PROCEDURE pwl_deriv_x_vec

END SUBMODULE pwl_implementation


	SUBROUTINE SN_INTC  ( data, nparms, nlev, tmpc, p, h, iret )
C************************************************************************
C* SN_INTC								*
C*									*
C* This subroutine finds the pressure and height of temperature, TMPC	*
C* from climatology sounding data. It assumes that the temperature	*
C* decreases monotonically with	height, and the temperature at the	*
C* lowest level is always warmer than TMPC.  If TMPC is colder than	*
C* the sounding, an extrapolation of the top level data is used		*
C*									*
C* SN_INTC  ( DATA, NPARMS, NLEV, TMPC, P, H, IRET )			*
C*									*
C* Input parameters:							*
C*	DATA		REAL		Climatology sounding data	*
C*	  (NPARMS, NLEV)						*
C*	NPARMS		INTEGER		Number of parameters		*
C*	NLEV		INTEGER		Number of levels		*
C*	TMPC		REAL		Temperature in Celsius		*
C*									*
C* Output parameters:							*
C*	P		REAL		Pressure			*
C*	H		REAL		Height				*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal			*
C*                                       +6 = Warm sounding		*
C**									*
C* Log:									*
C* T. Lee/GSC		 5/00	Initial coding				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	PARAMETER	( JPRE = 1, JTMP = 2, JHGT = 3 )
	REAL		data ( nparms, * )
C*
	LOGICAL		done
C------------------------------------------------------------------------
	iret = 0
C
C*	Return if TMPC is warmer than the sounding.
C
	IF  (  tmpc .gt. data ( JTMP, 1 ) )  THEN
	    iret = +6
	    p    = RMISSD
	    h    = 0.
	    RETURN
	END IF
C
	k = 1
	ntop = nlev
	done = .false.
	tb = data ( JTMP, k )
	zb = data ( JHGT, k )
	pb = data ( JPRE, k )
C
C*	Loop through the level and find the intersection.
C
	DO WHILE  ( .not. done )
	    tu = data ( JTMP, k + 1 )
	    zu = data ( JHGT, k + 1 )
	    pu = data ( JPRE, k + 1 )
C
	    IF  (  tu .le. tmpc )  THEN
C
C*	        An intersection is hit.
C
		rmult = ( tmpc - tb ) / ( tu - tb )
		plog = ALOG ( pu ) - ALOG ( pb )
		p  = pb * EXP ( plog * rmult )
		h  = zb + ( zu - zb ) * rmult
		RETURN
	      ELSE
		tb = tu
		zb = zu
		pb = pu
		k = k + 1
		IF  ( k .ge. ntop ) done = .true.
	    END IF
	END DO
C
C*	Extrapolate the temperature at top two levels if needed.
C
	zb = data ( JHGT, ntop - 1 )
	tb = data ( JTMP, ntop - 1 )
	pb = data ( JPRE, ntop - 1 )
	rmult = ( tmpc - tu ) /  ( tu - tb )
	plog = ALOG ( pu ) - ALOG ( pb )
	p  = pu * EXP ( plog * rmult )
	h  = zu + ( zu - zb ) * rmult
C*
	RETURN
	END


C$Procedure INSANG ( Inside Tetrahedral Angle )

      SUBROUTINE INSANG ( V, E1, E2, E3, FOUND, SCALE )

C$ Abstract
C
C     Determine if a given vector lies inside the solid tetrahedral
C     angle determined by 3 vectors. If it does, return the
C     point where the scale factor such that SCALE*V lies in the
C     plane spanned by E1, E2, and E3.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C      None.
C
C$ Keywords
C
C      VECTOR
C
C$ Declarations

      IMPLICIT NONE
      DOUBLE PRECISION      V     ( 3 )
      DOUBLE PRECISION      E1    ( 3 )
      DOUBLE PRECISION      E2    ( 3 )
      DOUBLE PRECISION      E3    ( 3 )
      LOGICAL               FOUND
      DOUBLE PRECISION      SCALE

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     V          I   Vector to test for "betweenness"
C     E1         I   First edge of the tetrahedral angle
C     E2         I   Second edge of the tetrahedral angle
C     E3         I   Third edge of the tetrahedral angle
C     FOUND      O   Indicates whether V lies in the solid angle
C     SCALE      O   Scale times V is in the triangle E1,E2,E3
C
C$ Detailed_Input
C
C     V          is a 3-vector.  This is the vector to test to see
C                if it lies between the 3 vectors E1, E2 and E3
C
C     E1         are the three edges of a solid tetrahedral angle.
C     E2         (See particulars for a discussion of the solid
C     E3         angle).
C
C$ Detailed_Output
C
C     FOUND      indicates that V lies inside the solid tetrahedral
C                angle determined by E1, E2 and E3.
C
C
C     SCALE      if V lies inside the solid tetrahedral angle given
C                by E1, E2 and E3, SCALE*V is the point is the positive
C                scalar multiple of V that pierces the triangle
C                determined by the points E1, E2, E3.
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If E1, E2 and E3 are not linearly independent, the routine
C        returns FALSE. SCALE will be set to 0.
C
C     2) If V is the zero vector, the routine returns FALSE.
C        SCALE will be set to 0.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Given 3 linearly independent vectors E1, E2, and E3 the
C     set of vectors a*E1 + b*E2 + c*E3  where a, b, and c
C     are non-negative form a region of space that is a tetrahedral
C     solid angle.  If you cut this solid angle with a plane
C     that intersects all three rays from the origin determined
C     by E1, E2 and E3 you will get a tetrahedron (a 4-sided
C     solid with each face a triangle).
C
C     This routine determines whether the ray associated with
C     a vector V lies inside the tetrahedral angle E1,E2,E3.
C     Moreover, if V lies inside this angle, this routine returns
C     the scale factor SCALE such that the point SCALE*V
C     lies in the plane containing the points E1, E2 and E3.
C     This is necessarily a point in the triangle determined by
C     E1, E2 and E3.
C
C$ Examples
C
C     Suppose you have a triangle in space specified by three
C     vertices P1, P2 and P3 and that an observer at location
C     OBS is looking along the ray emanating from OBS with
C     direction V.  Does this ray intersect the triangle
C     P1, P2, P3?  Using this routine, you can answer this
C     question and give the point of intersection if there is
C     one.  Here's how.
C
C     First construct the vectors from OBS to the corners of
C     the triangle.
C
C     CALL VSUB ( P1, OBS, E1 )
C     CALL VSUB ( P2, OBS, E2 )
C     CALL VSUB ( P3, OBS, E3 )
C
C     Now see if V lies between the vectors E1, E2, E3 and return
C     the intersection point if it does.
C
C     CALL INSANG ( V, E1, E2, E3, FOUND, SCALE )
C
C     If there was an intersection, add SCALE*V to OBS to get the
C     point of intersection.  Otherwise say there was no intersection.
C
C     IF ( FOUND ) THEN
C
C        CALL VLCOM ( 1.0D0, OBS, SCALE, V, POINT )
C
C        WRITE (*,*) 'The ray intersects the triangle at:
C        WRITE (*,*) POINT(1)
C        WRITE (*,*) POINT(2)
C        WRITE (*,*) POINT(3)
C
C     ELSE
C
C        WRITE (*,*) 'There is no intersection.'
C
C     END IF
C
C$ Restrictions
C
C     This routine can suffer from extreme loss of precision if
C     the vectors E1, E2, E3 are too long compared to the lengths
C     of the line segments formed by their pairwise differences.
C
C     The user of this routine must ensure that the inputs are
C     suitable.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 02-FEB-2016 (NJB)
C
C        Fixed comment typos. Updated Restrictions.
C
C-    SPICELIB Version 1.0.1, 08-OCT-2009 (NJB)
C
C        Updated header.
C
C-    SPICELIB Version 1.0.0, 09-JUN-1996 (WLT)
C
C
C-&

C$ Index_Entries
C
C     Determine if a vector lies in a solid tetrahedral angle
C
C-&
C
C     SPICELIB Functions
C
      DOUBLE PRECISION      VDOT

C
C     Local Variables
C
      DOUBLE PRECISION      DENOM
      DOUBLE PRECISION      EN
      DOUBLE PRECISION      NORM12 ( 3 )
      DOUBLE PRECISION      NORM23 ( 3 )
      DOUBLE PRECISION      NORM31 ( 3 )
      DOUBLE PRECISION      VN12
      DOUBLE PRECISION      VN23
      DOUBLE PRECISION      VN31
C
C     Our initial value for SCALE is zero.  When we have better
C     information, we'll change this.
C
      SCALE = 0.0D0

C
C     First we construct a normal to the plane spanned by E1 and E2
C     and make sure that we don't get a zero vector.  If we
C     get the zero vector, E1 and E2 are linearly dependent so we
C     set the value of FOUND to FALSE and return.
C
      CALL VCRSS ( E1, E2, NORM12 )

C
C     First make sure V and E3 are in the same half space
C     bounded by E1 and E2.  If they are not, we can return.
C
      VN12 = VDOT( V,  NORM12 )
      EN   = VDOT( E3, NORM12 )
C
C     Determine whether NORML and E3 are perpendicular.  If they
C     are perpendicular, E3 is a linear combination of E1 and E2.
C     In this case set FOUND to FALSE and return.
C
      IF ( EN .EQ. 0.0D0 ) THEN
         FOUND = .FALSE.
         RETURN
      END IF
C
C     Now check to see if V and E3 are in the same half space.  If
C     not, we can stop and return the value FALSE.
C
      IF (       EN   .GT. 0.0D0
     .     .AND. VN12 .LT. 0.0D0 ) THEN

         FOUND = .FALSE.
         RETURN

      ELSE IF (       EN   .LT. 0.0D0
     .          .AND. VN12 .GT. 0.0D0 ) THEN

         FOUND = .FALSE.
         RETURN

      END IF

C
C     Now check that V and E1 are on the same side of the plane
C     spanned by E2 and E3.  Note we don't have to compute EN
C     again <( E2 x E3 ), E1 >  because of the vector identity
C
C       < (E1 x E2), E3 > =  < (E2 x E3), E1 > = < (E3 x E1), E2 >
C
      CALL VCRSS ( E2, E3, NORM23 )
      VN23 = VDOT  ( V,      NORM23 )

C
C     The following tests are the same as in the previous case.
C
      IF (       EN   .GT. 0.0D0
     .     .AND. VN23 .LT. 0.0D0 ) THEN

         FOUND = .FALSE.
         RETURN

      ELSE IF (       EN   .LT. 0.0D0
     .          .AND. VN23 .GT. 0.0D0 ) THEN

         FOUND = .FALSE.
         RETURN

      END IF

C
C     Finally check to see if V and E2 are in the same half space
C     bounded by E3 and E2
C
      CALL VCRSS ( E3, E1, NORM31 )
      VN31 = VDOT  ( V,      NORM31 )

      IF (       EN   .GT. 0.0D0
     .     .AND. VN31 .LT. 0.0D0 ) THEN

         FOUND = .FALSE.
         RETURN

      ELSE IF (       EN   .LT. 0.0D0
     .          .AND. VN31 .GT. 0.0D0 ) THEN

         FOUND = .FALSE.
         RETURN

      END IF

C
C     If you get this far, we know that V is lies in the intersection
C     of the half spaces determined by the various combinations of
C     E1, E2 and E3.
C
      FOUND = .TRUE.

C
C     Now find the intersection. First get a normal to the triangle.
C     One way to get the normal is to find the vector cross
C     product
C
C       NORML = ( E2 - E1 ) x ( E3 - E1 )
C
C     However, this can be rewritten as:
C
C        NORML = E2 x E3 - E1 x E3 - E2 x E1 + E1 x E1
C
C              = E2 x E3 + E3 x E1 + E1 x E2
C
C     But we already have the three components E2 x E3, ... etc.
C     in the vectors NORM12, NORM23, NORM31
C
C     Now we need to find the scalar multiple t*V such that
C
C        < tV - E1, NORML > = 0
C
C     But this can be rewritten as:
C
C        t < V, NORML > = < E1, NORML >
C
C     Solving for t yields
C
C      t = < E1, NORML > / < V, NORML >
C
C        = < E1, E1xE2 + E2xE3 + E3xE1 > / <  V, E1xE2 + E2xE3 + E3xE1 >
C
C        = ( 0 + <E1, E2xE3> + 0 ) / (<V,E1xE2> + <V,E2xE3> + <V,E3xE1>)
C
C        =  EN / ( VN12 + VN23 + VN31 )
C
      DENOM = VN12 + VN23 + VN31

      IF ( DENOM .EQ. 0.0D0 ) THEN
         FOUND = .FALSE.
      ELSE
         FOUND = .TRUE.
         SCALE =  EN/DENOM
      END IF

      RETURN
      END


Submodule ( statistical_data_mod ) statistical_skewness_smod
!
  Use kind_parameters_mod
!
  Implicit None
!
Contains
!
  Module Procedure Statistical_Skewness
!
    Real(KIND=rkind) :: mn, sd
    If ( Size(this%data) .ne. 0 ) Then
       If ( Present ( mean ) ) Then
          mn = mean
       Else
          If ( this%Dmean ) Then
             mn = this%mean
          Else
             mn = Statistical_Mean ( this )
          End If
       End If
       If ( Present ( std_dev ) ) Then
          sd = std_dev
       Else
          If ( this%Dstd_dev ) Then
             sd = this%std_dev
          Else
             sd = Statistical_Std_Dev ( this, mn )
          End If
       End If
       If ( sd .ne. 0.0d0 ) Then
          skewness = Sum ( (this%data-mn)**3 ) / Size ( this%data ) / sd**3
       Else
          skewness = Huge ( skewness )
       End If
    Else
       skewness = Huge ( skewness )
    End If
    this%skewness = skewness
    this%Dskewness = .true.
!
  End Procedure Statistical_Skewness
!
End Submodule statistical_skewness_smod


!
!  spat_oper_mod.f90
!
! This module contains routines that are involved in the evaluation of the spatial operator
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module BGKVDCF0D_spat_oper_mod
use nrtype ! contains kind parameters (DP), (DP), (I4B) etc.
implicit none

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! SpatialOperSH_DGV (f)
!
! This operator evaluates the spatial operator
!
!
! in 0D / the spatially homogeneous case the spatial operator
! only has the collisoin operator
!
! in 1D and 2D there will be also operators evaluating thr transport part, fluxes and so on
!
! COMMENT: STILL NEED TO ADD COLLISION FREQUENCY!
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine SpatialOperSH_DGV (f,fcol,dt)

use BGKVDCF0D_commvar, only: time
use DGV_collision_mod

!!!!!!!!!!!!!!!!!!!!!!
real (DP), dimension (:), intent (in) :: f ! the solution at the current
real (DP), dimension (:), intent (out) :: fcol ! value of the right side
real (DP), intent (in) :: dt ! The time step
!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Since there is no transport terms, flux terms and so on, we just call the
!! right hand side, which in this case is accomplished by calling the
!! collision operator

call UniversalCollisionOperator0DDGV(f,fcol,time,dt)

!!!

end subroutine SpatialOperSH_DGV

end module BGKVDCF0D_spat_oper_mod


!****************************************************************************
! module: prec
! COMMENT: Define parameter for NRG subroutine
!****************************************************************************

    module prec

        implicit none
        integer,parameter::Rkind=8

    end module prec

!****************************************************************************
! module: precnpl
! COMMENT: Define parameter for NRG subroutine
!****************************************************************************

    module precnpl

        use prec
        implicit none

        integer,parameter:: Nit=200, Nnit=30         ! Max iteration numbers.
        integer,parameter:: Nb0=2000, Ns=80, Nb=30, Dim=2400

        real(kind=Rkind), parameter:: Pi=3.141526535_Rkind
        real(kind=Rkind), parameter:: Lamda=10.0_Rkind
        real(kind=Rkind), parameter:: wc=1.0_Rkind, s=0.5_Rkind

        real(kind=Rkind):: dta_loc=0.1_Rkind, epi_loc=0.0_Rkind   !  local term
        real(kind=Rkind):: g1_cps=0.0_Rkind, g2_cps=1.0_Rkind      !  coupling strenth

    end module precnpl

!****************************************************************************
! PROGRAM: NPL_NRG
! TYPE   : Main
! PURPOSE: Nonlear + Linear
!****************************************************************************
    program NPL_NRG
    use precnpl
    implicit none

    integer:: i, j, k, ierror, ierror2, jishu

    real(kind=Rkind):: time_begin, time_end
    real(kind=Rkind):: eta0, epi0, t0, epin, tn
    real(kind=Rkind):: alpha
    real(kind=Rkind),dimension(0:Nit):: epi, t

    real(kind=Rkind),dimension(Ns):: Eigenv
    real(kind=Rkind),dimension(Ns, Ns):: bmatrixc, bmatrixa, qzmatrix, qxmatrix, b0matrixa, b0matrixc, x2matrix, nmatrix
    real(kind=Rkind),dimension(50, 0:Nit, Ns):: Eigenv_all, w_all, cw_all, cwx_all, cwsx_all

!--- Begin ---
    call cpu_time(time_begin)
    alpha=0.0000265392_Rkind

!--- Begin Caculation
    Eigenv_all=0.0_Rkind
    w_all=0.0_Rkind
    cw_all=0.0_Rkind
    cwx_all=0.0_Rkind
    cwsx_all=0.0_Rkind

!$omp do
    do j=1, 1

        call param(alpha, eta0, epi, t)

        !--- First iteration
        epi0=epi(0)
        call diag_H0(eta0, epi0, Eigenv, bmatrixc, bmatrixa, qzmatrix, qxmatrix, b0matrixa, b0matrixc, x2matrix, nmatrix)
        print *, "<qz>:", qzmatrix(1, 1), qxmatrix(1, 1), abs(b0matrixa(1, 1)+b0matrixc(1, 1)), x2matrix(1, 1), nmatrix(1, 1)

        do k=1, Ns
            Eigenv_all(j, 0, k)=Eigenv(k)                  !--- Save eigenv
            w_all(j, 0, k)=Eigenv(k)
            cw_all(j, 0, k)=0.5_Rkind*(qzmatrix(1, k)**2)
            cwsx_all(j, 0, k)=0.5_Rkind*(qxmatrix(1, k)**2)
            cwx_all(j, 0, k)=0.5_Rkind*((b0matrixa(1, k)+b0matrixc(1, k))**2)
        end do

        !--- Later iterations
        do i=1, Nnit

            epin=epi(i)
            tn=Lamda*t(i-1)
            call diag_Hn(epin, tn, Eigenv, bmatrixc, bmatrixa, qzmatrix, qxmatrix, b0matrixa, b0matrixc, x2matrix, nmatrix)
            print *, "<qz>:", qzmatrix(1, 1), abs(b0matrixa(1, 1)+b0matrixc(1, 1)), x2matrix(1, 1), nmatrix(1, 1)

            do k=1, Ns
                Eigenv_all(j, i, k)=Eigenv(k)                   !--- Save eigenv
                w_all(j, i, k)=Eigenv(k)*(Lamda**(-i))
                cw_all(j, i, k)=0.5_Rkind*(qzmatrix(1, k)**2)
                cwsx_all(j, i, k)=0.5_Rkind*(qxmatrix(1, k)**2)
                cwx_all(j, i, k)=0.5_Rkind*((b0matrixa(1, k)+b0matrixc(1, k))**2)
            end do

        end do

        !--- Physical information. Saved to disk.
        OPEN (UNIT=2, FILE='m.TXT', STATUS='UNKNOWN', ACTION='WRITE', IOSTAT=ierror2)
        WRITE (2,900) alpha, qzmatrix(1, 1), qxmatrix(1, 1), (b0matrixa(1, 1)+b0matrixc(1, 1)), x2matrix(1, 1), nmatrix(1, 1), (abs(b0matrixa(1, 1)+b0matrixc(1, 1))**2)/x2matrix(1, 1)
        900 FORMAT (F, F, F, F, F, F, F)

        alpha = alpha + 0.0000001_Rkind

    end do
!$omp end do

!--- Flow diagrams. Saved to disk.
    jishu=0
    do i=0, Nnit

        OPEN (UNIT=1, FILE="flow.TXT", STATUS='UNKNOWN', ACTION='WRITE', IOSTAT=ierror)
        WRITE (1,700) jishu, Eigenv_all(1, i, 2), Eigenv_all(2, i, 2), Eigenv_all(3, i, 2), Eigenv_all(4, i, 2), Eigenv_all(5, i, 2), Eigenv_all(6, i, 2), Eigenv_all(7, i, 2), Eigenv_all(8, i, 2)
        700 FORMAT (I, F, F, F, F, F, F, F, F)

        jishu=jishu+1

    end do

    !call calc_cw(w_all, cw_all)
    !call calc_cwx(w_all, cwx_all)
    call calc_cwsx(w_all, cwsx_all)

!--- End----
    call cpu_time(time_end)
    print *, 'Time of operation was : ', time_end - time_begin, ' seconds'

    end program NPL_NRG

!========+=========+===============+=========+=$
! PROGRAM: calc_cwsx
! TYPE   : subroutine
! PURPOSE:
!========+=========+===============+=========+=$
    subroutine calc_cwsx(w_all, cwsx_all)
    use precnpl
    implicit none

    integer:: i, j, k, ierror3, ierror4, ierror8
    real(kind=Rkind):: sum, w, res_cwsx, dlt_tmp

    real(kind=Rkind),dimension(50, 0:Nit, Ns):: w_all, cwsx_all

    do i=0, Nnit
        print *, 'w_max: ', w_all(1, i, Ns)
    end do

    do i=0, Nnit
        do j=1, Ns

        OPEN (UNIT=18, FILE="cwsx_origin.TXT", STATUS='UNKNOWN', ACTION='WRITE', IOSTAT=ierror8)
        WRITE (18,2018)  w_all(1, i, j), cwsx_all(1, i, j)
        2018 FORMAT (F, F)

        end do
    end do

    do i=1, Nnit
        do j=0, i-1

            k=1
            do
            if(w_all(1, j, k)>w_all(1, i, Ns)) exit
            cwsx_all(1, j, k)=cwsx_all(1, j, k)*(w_all(1, j, k)/w_all(1, i, Ns))
            k=k+1
            end do

        end do

        do j=1, Ns
            cwsx_all(1, i, j)=cwsx_all(1, i, j)*(1-(w_all(1, i, j)/w_all(1, i, Ns)))
        end do
    end do

    do i=0, Nnit
        print *, 'cw_0: ', cwsx_all(1, i, 1)
    end do

    sum=0.0_Rkind
    do i=0, Nnit
        do j=1, Ns
        sum=sum+cwsx_all(1, i, j)
        end do
    end do
    print *, 'sum: ', sum

    w=0.0_Rkind
    do k=1, 90

        res_cwsx=0.0_Rkind
        do i=0, Nnit
            do j=1, Ns

                if(w_all(1, i, j)==0.0_Rkind) then

                    dlt_tmp=0.0_Rkind

                else

                    dlt_tmp=0.6_Rkind**2
                    dlt_tmp=exp(-(dlt_tmp/4))/(0.6_Rkind*w_all(1, i, j)*sqrt(Pi))
                    dlt_tmp=dlt_tmp*exp(-((log(w)-log(w_all(1, i, j)))**2)/(0.6_Rkind**2))

                end if

                res_cwsx=res_cwsx+cwsx_all(1, i, j)*dlt_tmp
            end do
        end do

            OPEN (UNIT=28, FILE="res_cwsx.TXT", STATUS='UNKNOWN', ACTION='WRITE', IOSTAT=ierror3)
            WRITE (28,2028)  w, res_cwsx
            2028 FORMAT (F, F)

        w=0.00000000000001_Rkind*1.5_Rkind**k
    end do

    do i=0, Nnit
        do j=1, Ns

        OPEN (UNIT=29, FILE="cwsx.TXT", STATUS='UNKNOWN', ACTION='WRITE', IOSTAT=ierror4)
        WRITE (29 ,2029)  w_all(1, i, j), cwsx_all(1, i, j)
        2029 FORMAT (F, F)

        if(cwsx_all(1, i, j)>0.01_Rkind) then
        print *, 'i  j', i, j, w_all(1, i, j), cwsx_all(1, i, j)
        end if

        end do
    end do

    end subroutine calc_cwsx

!========+=========+===============+=========+=$
! PROGRAM: calc_cw
! TYPE   : subroutine
! PURPOSE:
!========+=========+===============+=========+=$
    subroutine calc_cw(w_all, cw_all)
    use precnpl
    implicit none

    integer:: i, j, k, ierror3, ierror4, ierror8
    real(kind=Rkind):: sum, w, res_cw, dlt_tmp

    real(kind=Rkind),dimension(50, 0:Nit, Ns):: w_all, cw_all

    do i=0, Nnit
        print *, 'w_max: ', w_all(1, i, Ns)
    end do

    do i=0, Nnit
        do j=1, Ns

        OPEN (UNIT=8, FILE="cw_origin.TXT", STATUS='UNKNOWN', ACTION='WRITE', IOSTAT=ierror8)
        WRITE (8,2000)  w_all(1, i, j), cw_all(1, i, j)
        2000 FORMAT (F, F)

        end do
    end do

    do i=1, Nnit
        do j=0, i-1

            k=1
            do
            if(w_all(1, j, k)>w_all(1, i, Ns)) exit
            cw_all(1, j, k)=cw_all(1, j, k)*(w_all(1, j, k)/w_all(1, i, Ns))
            k=k+1
            end do

        end do

        do j=1, Ns
            cw_all(1, i, j)=cw_all(1, i, j)*(1-(w_all(1, i, j)/w_all(1, i, Ns)))
        end do
    end do

    do i=0, Nnit
        print *, 'cw_0: ', cw_all(1, i, 1)
    end do

    sum=0.0_Rkind
    do i=0, Nnit
        do j=1, Ns
        sum=sum+cw_all(1, i, j)
        end do
    end do
    print *, 'sum: ', sum

    w=0.0_Rkind
    do k=1, 90

        res_cw=0.0_Rkind
        do i=0, Nnit
            do j=1, Ns

                if(w_all(1, i, j)==0.0_Rkind) then

                    dlt_tmp=0.0_Rkind

                else

                    dlt_tmp=0.6_Rkind**2
                    dlt_tmp=exp(-(dlt_tmp/4))/(0.6_Rkind*w_all(1, i, j)*sqrt(Pi))
                    dlt_tmp=dlt_tmp*exp(-((log(w)-log(w_all(1, i, j)))**2)/(0.6_Rkind**2))

                end if

                res_cw=res_cw+cw_all(1, i, j)*dlt_tmp
            end do
        end do

            OPEN (UNIT=3, FILE="res_cw.TXT", STATUS='UNKNOWN', ACTION='WRITE', IOSTAT=ierror3)
            WRITE (3,900)  w, res_cw
            900 FORMAT (F, F)

        w=0.00000000000001_Rkind*1.5_Rkind**k
    end do

    do i=0, Nnit
        do j=1, Ns

        OPEN (UNIT=4, FILE="cw.TXT", STATUS='UNKNOWN', ACTION='WRITE', IOSTAT=ierror4)
        WRITE (4,1000)  w_all(1, i, j), cw_all(1, i, j)
        1000 FORMAT (F, F)

        if(cw_all(1, i, j)>0.01_Rkind) then
        print *, 'i  j', i, j, w_all(1, i, j), cw_all(1, i, j)
        end if

        end do
    end do

    end subroutine calc_cw

!========+=========+===============+=========+=$
! PROGRAM: calc_cwx
! TYPE   : subroutine
! PURPOSE:
!========+=========+===============+=========+=$
    subroutine calc_cwx(w_all, cwx_all)
    use precnpl
    implicit none

    integer:: i, j, k, ierror5, ierror6
    real(kind=Rkind):: sum, w, res_cwx, dlt_tmp

    real(kind=Rkind),dimension(50, 0:Nit, Ns):: w_all, cwx_all

    do i=0, Nnit
        print *, 'w_max: ', w_all(1, i, Ns)
    end do

    do i=1, Nnit
        do j=0, i-1

            k=1
            do
            if(w_all(1, j, k)>w_all(1, i, Ns)) exit
            cwx_all(1, j, k)=cwx_all(1, j, k)*(w_all(1, j, k)/w_all(1, i, Ns))
            k=k+1
            end do

        end do

        do j=1, Ns
            cwx_all(1, i, j)=cwx_all(1, i, j)*(1-(w_all(1, i, j)/w_all(1, i, Ns)))
        end do
    end do

    do i=0, Nnit
        print *, 'cwx_0: ', cwx_all(1, i, 1)
    end do

    sum=0.0_Rkind
    do i=0, Nnit
        do j=1, Ns
        sum=sum+cwx_all(1, i, j)
        end do
    end do
    print *, 'sum: ', sum

    do k=1, 90
    w=0.00000000000001_Rkind*1.5_Rkind**k

        res_cwx=0.0_Rkind
        do i=0, Nnit
            do j=1, Ns

                if(w_all(1, i, j)<0.0000000000000001_Rkind) then

!                   dlt_tmp=(0.5_Rkind/Pi)*0.6_Rkind/((w-w_all(1, i, j))**2+0.6_Rkind**2)
                    dlt_tmp=0.0_Rkind

                else

                    dlt_tmp=0.6_Rkind**2
                    dlt_tmp=exp(-(dlt_tmp/4))/(0.6_Rkind*w_all(1, i, j)*sqrt(Pi))
                    dlt_tmp=dlt_tmp*exp(-((log(w)-log(w_all(1, i, j)))**2)/(0.6_Rkind**2))

                end if

                res_cwx=res_cwx+cwx_all(1, i, j)*dlt_tmp
            end do
        end do

            OPEN (UNIT=5, FILE="res_cwx.TXT", STATUS='UNKNOWN', ACTION='WRITE', IOSTAT=ierror5)
            WRITE (5,1100)  w, res_cwx
            1100 FORMAT (F, F)

    end do

    do i=0, Nnit
        do j=1, Ns

        OPEN (UNIT=6, FILE="cwx.TXT", STATUS='UNKNOWN', ACTION='WRITE', IOSTAT=ierror6)
        WRITE (6,1200)  w_all(1, i, j), cwx_all(1, i, j)
        1200 FORMAT (F, F)

        if(cwx_all(1, i, j)>0.01_Rkind) then
        print *, 'i  j', i, j, w_all(1, i, j), cwx_all(1, i, j)
        end if

        end do
    end do

    end subroutine calc_cwx

!========+=========+===============+=========+=$
! PROGRAM: param
! TYPE   : subroutine
! PURPOSE: Produce NRG Paranmeters
!========+=========+===============+=========+=$
    subroutine param(alpha, eta0, epi, t)
    use precnpl
    implicit none

!--- Define parameter----
    integer:: i, j, k, Isign

    real(kind=Rkind):: alpha
    real(kind=Rkind):: eta0, tmp1, tmp2
    real(kind=Rkind),dimension(0:Nit):: xi, gama2, epi, t, orth
    real(kind=Rkind),dimension(0:Nit,0:Nit):: Umatrix

    do i=0, Nit-1
        gama2(i)=(2*Pi*alpha)*(wc**2)*(1-lamda**(-(s+1)))*(lamda**(-i*(s+1)))/(s+1)
        xi(i)=((s+1)/(s+2))*((1-lamda**(-(s+2)))/(1-lamda**(-(s+1))))*wc*(lamda**(-i))
    end do

    eta0=0.0_Rkind
    do i=0, Nit-1
        eta0=eta0+gama2(i)
    end do

    Umatrix=0.0_Rkind
    epi=0.0_Rkind
    do i=0, Nit-1
        tmp1=gama2(i)/eta0
        Umatrix(0, i)=sqrt(tmp1)
        epi(0)=epi(0)+xi(i)*tmp1
    end do

    t=0.0_Rkind
    do i=0, Nit-1
        t(0)=((xi(i)-epi(0))*Umatrix(0, i))**2+t(0)
    end do
    t(0)=sqrt(t(0))

    do i=0, Nit-1
        Umatrix(1, i)=(xi(i)-epi(0))*Umatrix(0, i)/t(0)
        epi(1)=epi(1)+xi(i)*(Umatrix(1, i)**2)
    end do

    do i=0, Nit-1
        t(1)=((xi(i)-epi(1))*Umatrix(1, i)-t(0)*Umatrix(0, i))**2+t(1)
    end do
    t(1)=sqrt(t(1))

!----------iteration-----------
    do i=2, Nit-1

        do j=0, Nit-1
            Umatrix(i, j)=((xi(j)-epi(i-1))*Umatrix(i-1, j)-t(i-2)*Umatrix(i-2, j))/t(i-1)
        end do

!----------orth-----------
        orth=0.0_Rkind
        do j=0, i-1

            tmp2=0.0_Rkind
            do k=0, Nit-1
                tmp2=tmp2+Umatrix(i, k)*Umatrix(j, k)
            end do

            do k=0, Nit-1
                orth(k)=orth(k)+tmp2*Umatrix(j, k)
            end do

        end do

        do j=0, Nit-1
            Umatrix(i, j)=Umatrix(i, j)-orth(j)
        end do

        tmp2=0.0_Rkind
        do j=0, Nit-1
            tmp2=tmp2+Umatrix(i, j)*Umatrix(i, j)
        end do

        tmp2=sqrt(tmp2)
        do j=0, Nit-1
            Umatrix(i, j)=Umatrix(i, j)/tmp2
        end do

        do j=0, Nit-1
            epi(i)=epi(i)+xi(j)*(Umatrix(i, j)**2)
        end do

        do j=0, Nit-1
            t(i)=((xi(j)-epi(i))*Umatrix(i, j)-t(i-1)*Umatrix(i-1, j))**2+t(i)
        end do
        t(i)=sqrt(t(i))

    end do

    do i=0, Nit-1
        t(i)=t(i)*(lamda**i)
        epi(i)=epi(i)*(lamda**i)
        print *, i, t(i), epi(i)
    end do

    Isign=15
!        print *, Isign-4, t(Isign-4)
!        print *, Isign-3, t(Isign-3)
!        print *, Isign-2, t(Isign-2)
!        print *, Isign-1, t(Isign-1)
!        print *, Isign, t(Isign)
!        print *, Isign+1, t(Isign+1)
!        print *, Isign+2, t(Isign+2)
!        pause

    do i=Isign+1, Nit-1
        epi(i)=epi(Isign)
        t(i)=t(Isign)
    end do

    end subroutine param

!========+=========+===============+=========+=$
! PROGRAM: diag_H0
! TYPE   : subroutine
! PURPOSE:
!========+=========+===============+=========+=$
    subroutine diag_H0(eta0, epi0, Eigenv, bmatrixc, bmatrixa, qzmatrix, qxmatrix, b0matrixa, b0matrixc, x2matrix, nmatrix)
    use precnpl
    implicit none

    integer:: i, j, k

    real(kind=Rkind):: eta0, epi0, t0, Coeff0, Coeff1, tmp, sum1, sum2

    real(kind=Rkind),dimension(Ns):: Eigenv
    real(kind=Rkind),dimension(Nb0):: vec_mid, vec_mid1, vec_mid2
    real(kind=Rkind),dimension(Ns, Ns):: bmatrixc, bmatrixa, qzmatrix, qxmatrix, b0matrixa, b0matrixc, x2matrix, nmatrix
    real(kind=Rkind),dimension(Nb0, Nb0):: H0
    real(kind=Rkind),dimension(Nb0/2, Nb0/2):: H01

    integer:: cevec=1
    integer:: ierr
    real(kind=Rkind),dimension(Nb0):: eigvalue, fv1, fv2
    real(kind=Rkind),dimension(Nb0, Nb0):: eigvector

!    print *, "eta0, epi0:", eta0, epi0
    H0=0.0_Rkind

!----------loc term-----------
    do i=1, Nb0/2
        H0(i, i)=H0(i, i)+(epi_loc/2)
        H0(i+Nb0/2, i+Nb0/2)=H0(i+Nb0/2, i+Nb0/2)-(epi_loc/2)
        H0(i+Nb0/2, i)=H0(i+Nb0/2, i)-(dta_loc/2)
        H0(i, i+Nb0/2)=H0(i, i+Nb0/2)-(dta_loc/2)
    end do

!----------linear term-----------
    Coeff0=g1_cps*sqrt(eta0/Pi)/2

    do i=1, Nb0/2-1
        tmp=i
        tmp=sqrt(tmp)
        tmp=Coeff0*tmp
        H0(i, i+1)=H0(i, i+1)+tmp
        H0(i+1, i)=H0(i+1, i)+tmp
        H0(i+Nb0/2, i+Nb0/2+1)=H0(i+Nb0/2, i+Nb0/2+1)-tmp
        H0(i+Nb0/2+1, i+Nb0/2)=H0(i+Nb0/2+1, i+Nb0/2)-tmp
    end do

!----------nonlinearg term-----------
    Coeff1=g2_cps*eta0/Pi/2

    H01=0.0_Rkind
    do i=1, Nb0/2-1
        tmp=i
        tmp=sqrt(tmp)
        H01(i, i+1)=H01(i, i+1)+tmp
        H01(i+1, i)=H01(i+1, i)+tmp
    end do

    do i=1, Nb0/2
        do j=1, Nb0/2
            tmp=0.0_Rkind
            do k=1, Nb0/2
                tmp=tmp+H01(i, k)*H01(k, j)
            end do
            H0(i, j)=H0(i, j)+Coeff1*tmp
            H0(i+Nb0/2, j+Nb0/2)=H0(i+Nb0/2, j+Nb0/2)-Coeff1*tmp
        end do
    end do

!----------bath term-----------
    do i=1, Nb0/2
        H0(i, i)=H0(i, i)+epi0*(i-1)
        H0(i+Nb0/2, i+Nb0/2)=H0(i+Nb0/2, i+Nb0/2)+epi0*(i-1)
    end do

    do i=1, Nb0
        do j=1, Nb0
        if(H0(i, j)/=H0(j, i)) then
        print *, "e"
        pause
        end if
        end do
    end do

!    print *, H0

!-------------- diagonalize Hamilt matrix ------------------
!---- Call RS subroutine --------
!--using slatec in 1976: slower, but independent of compiler ----
!          call  rs (Nb0, Nb0, H0, eigvalue, &
!                            cevec, eigvector, fv1, fv2, ierr)
!--using Lapack: faster, but must with intel + Lapack ----
          call  rs_cpu (Nb0, Nb0, H0, eigvalue, &
                    cevec, eigvector, fv1, fv2, ierr)
!---------------------
    if (ierr/=0) then
        print *, 'error'
        stop
    endif
!----------------------------------------------------

!---- Output eigenvalues --------
    do i=1, Ns
        Eigenv(i)=eigvalue(i)
    end do

    tmp=Eigenv(1)
    do i=1, Ns
        Eigenv(i)=Eigenv(i)-tmp
    end do

!---- Write b0 matrix --------
    do i=1, Ns

        vec_mid1=0.0_Rkind
        do j=1, Nb0/2-1
            tmp=j
            tmp=sqrt(tmp)
            vec_mid1(j)=tmp*eigvector(j+1, i)
            vec_mid1(j+Nb0/2)=tmp*eigvector(j+Nb0/2+1, i)
        end do

        do j=1, Ns

            sum1=0.0_Rkind
            do k=1, Nb0
                sum1=sum1+vec_mid1(k)*eigvector(k, j)
            end do

            bmatrixa(j, i)=sum1
        end do
    end do

!---- Write b0+ matrix --------
    do i=1, Ns
        do j=1, Ns
            bmatrixc(i, j)=bmatrixa(j, i)
            b0matrixa(j, i)=bmatrixa(j, i)
            b0matrixc(i, j)=bmatrixa(j, i)
        end do
    end do

!---- Write x^2 matrix --------
    do i=1, Ns

        vec_mid=0.0_Rkind
        vec_mid1=0.0_Rkind
        vec_mid2=0.0_Rkind
        do j=1, Nb0/2-1
            tmp=j
            tmp=sqrt(tmp)
            vec_mid1(j)=tmp*eigvector(j+1, i)
            vec_mid1(j+Nb0/2)=tmp*eigvector(j+Nb0/2+1, i)
            vec_mid2(j+1)=tmp*eigvector(j, i)
            vec_mid2(j+Nb0/2+1)=tmp*eigvector(j+Nb0/2, i)
        end do

        do j=1, Nb0
            vec_mid(j)=vec_mid1(j)+vec_mid2(j)
        end do

        vec_mid1=0.0_Rkind
        vec_mid2=0.0_Rkind
        do j=1, Nb0/2-1
            tmp=j
            tmp=sqrt(tmp)
            vec_mid1(j)=tmp*vec_mid(j+1)
            vec_mid1(j+Nb0/2)=tmp*vec_mid(j+Nb0/2+1)
            vec_mid2(j+1)=tmp*vec_mid(j)
            vec_mid2(j+Nb0/2+1)=tmp*vec_mid(j+Nb0/2)
        end do

        do j=1, Nb0
            vec_mid(j)=vec_mid1(j)+vec_mid2(j)
        end do

        do j=1, Ns

            sum1=0.0_Rkind
            do k=1, Nb0
                sum1=sum1+vec_mid(k)*eigvector(k, j)
            end do

            x2matrix(j, i)=sum1
        end do
    end do

!---- Write <a+a> matrix --------
    do i=1, Ns

        do j=1, Ns

            sum1=0.0_Rkind
            do k=1, Nb0/2
                tmp=k-1
                sum1=sum1+tmp*eigvector(k, i)*eigvector(k, j)+tmp*eigvector(k+Nb0/2, i)*eigvector(k+Nb0/2, j)
            end do

            nmatrix(j, i)=sum1
        end do
    end do

!---- Write qx matrix --------
    do i=1, Ns
        do j=1, Ns

            sum2=0.0_Rkind
            do k=1, Nb0/2
                sum2=sum2+eigvector(k+Nb0/2, i)*eigvector(k, j)+eigvector(Nb0/2, i)*eigvector(k+Nb0/2, j)
            end do
            qxmatrix(j, i)=sum2

        end do
    end do

!---- Write qz matrix --------
    do i=1, Ns
        do j=1, Ns

            sum2=0.0_Rkind
            do k=1, Nb0/2
                sum2=sum2+eigvector(k, i)*eigvector(k, j)+eigvector(k+Nb0/2, i)*(-eigvector(k+Nb0/2, j))
            end do
            qzmatrix(j, i)=sum2

        end do
    end do

!---- Test Hermite --------
!    do i=1, Ns
!        do j=1, Ns
!            if(qzmatrix(i, j)/=qzmatrix(j, i)) then
!                print *, "e"
!                pause
!            end if
!        end do
!    end do

!    do i=1, Ns
!        do j=1, Ns
!            if(b0matrixa(i, j)/=b0matrixc(j, i)) then
!                print *, "e"
!                pause
!            end if
!        end do
!    end do

    end subroutine diag_H0

!========+=========+===============+=========+=$
! PROGRAM: diag_Hn
! TYPE   : subroutine
! PURPOSE:
!========+=========+===============+=========+=$
    subroutine diag_Hn(epin, tn, Eigenv, bmatrixc, bmatrixa, qzmatrix, qxmatrix, b0matrixa, b0matrixc, x2matrix, nmatrix)
    use precnpl
    implicit none

    integer:: i, j, k, l
    real(kind=Rkind):: epin, tn, tmp, sum1, sum2

    real(kind=Rkind),dimension(Nb, Nb):: bmatrixan1, bmatrixcn1

    real(kind=Rkind),dimension(Ns):: Eigenv
    real(kind=Rkind),dimension(Ns, Ns):: bmatrixc, bmatrixa, qzmatrix, newqzmatrix, qxmatrix, newqxmatrix, b0matrixa, newb0matrixa, b0matrixc, newb0matrixc, x2matrix, newx2matrix, nmatrix, newnmatrix

    real(kind=Rkind),dimension(Dim):: vec_mid1, vec_mid2
    real(kind=Rkind),dimension(Dim, Dim):: Hn

    integer:: cevec=1
    integer:: ierr
    real(kind=Rkind),dimension(Dim):: eigvalue, fv1, fv2
    real(kind=Rkind),dimension(Dim, Dim):: eigvector

    do i=1, Ns
        Eigenv(i)=Lamda*Eigenv(i)
    end do

    Hn=0.0_Rkind

!----------loc term-----------
    do i=1, Nb
        do j=1, Ns
            Hn(Ns*(i-1)+j, Ns*(i-1)+j)=Hn(Ns*(i-1)+j, Ns*(i-1)+j)+Eigenv(j)
        end do
    end do

!----------coupling term-----------
    bmatrixan1=0.0_Rkind
    bmatrixcn1=0.0_Rkind
    do i=1, Nb-1
        tmp=i
        tmp=sqrt(tmp)
        bmatrixan1(i, i+1)=bmatrixan1(i, i+1)+tmp
        bmatrixcn1(i+1, i)=bmatrixcn1(i+1, i)+tmp
    end do

    do i=1, Nb-1
        do j=1, Ns
            do k=1, Ns
            Hn(Ns*i+j, Ns*(i-1)+k)=Hn(Ns*i+j, Ns*(i-1)+k)+tn*bmatrixa(j, k)*bmatrixcn1(i+1, i)
            Hn(Ns*(i-1)+k, Ns*i+j)=Hn(Ns*(i-1)+k, Ns*i+j)+tn*bmatrixa(j, k)*bmatrixcn1(i+1, i)
            end do
        end do
    end do

!----------bath term-----------
    do i=1, Nb
        do j=1, Ns
            Hn(Ns*(i-1)+j, Ns*(i-1)+j)=Hn(Ns*(i-1)+j, Ns*(i-1)+j)+epin*(i-1)
        end do
    end do

!-------------- diagonalize Hamilt matrix ------------------
!---- Call RS subroutine --------
!--using slatec in 1976: slower, but independent of compiler ----
!          call  rs (Dim, Dim, Hn, eigvalue, &
!                          cevec, eigvector, fv1, fv2, ierr)
!--using Lapack: faster, but must with intel + Lapack ----
          call  rs_cpu (Dim, Dim, Hn, eigvalue, &
                                  cevec, eigvector, fv1, fv2, ierr)
!---------------------
    if (ierr/=0) then
        print *, 'error'
        stop
    endif
!----------------------------------------------------

    do i=1, Ns
        Eigenv(i)=eigvalue(i)
    end do

    tmp=Eigenv(1)
    do i=1, Ns
        Eigenv(i)=Eigenv(i)-tmp
    end do

    do i=1, Ns

        vec_mid1=0.0_Rkind
        do j=1, Nb-1
            tmp=j
            tmp=sqrt(tmp)
            do k=1, Ns
            vec_mid1(Ns*(j-1)+k)=tmp*eigvector(Ns*j+k, i)
            end do
        end do

        do j=1, Ns

            sum1=0.0_Rkind
            do k=1, Dim
                sum1=sum1+eigvector(k, j)*vec_mid1(k)
            end do

            bmatrixa(j, i)=sum1
        end do
    end do

    do i=1, Ns
        do j=1, Ns
            bmatrixc(i, j)=bmatrixa(j, i)
        end do
    end do

!---- Write qx matrix --------
    do i=1, Ns

        vec_mid2=0.0_Rkind
        do j=1, Nb
            do k=1, Ns
                tmp=0.0_Rkind
                do l=1, Ns
                    tmp=tmp+eigvector(Ns*(j-1)+l ,i)*qxmatrix(k ,l)
                end do
                vec_mid2(Ns*(j-1)+k)=tmp
            end do
        end do

        do j=1, Ns

            sum2=0.0_Rkind
            do k=1, Dim
                sum2=sum2+eigvector(k, j)*vec_mid2(k)
            end do
            newqxmatrix(j, i)=sum2
        end do
    end do

    do i=1, Ns
        do j=1, Ns
            qxmatrix(i, j)=newqxmatrix(i, j)
        end do
    end do

!---- Write qz matrix --------
    do i=1, Ns

        vec_mid2=0.0_Rkind
        do j=1, Nb
            do k=1, Ns
                tmp=0.0_Rkind
                do l=1, Ns
                    tmp=tmp+eigvector(Ns*(j-1)+l ,i)*qzmatrix(k ,l)
                end do
                vec_mid2(Ns*(j-1)+k)=tmp
            end do
        end do

        do j=1, Ns

            sum2=0.0_Rkind
            do k=1, Dim
                sum2=sum2+eigvector(k, j)*vec_mid2(k)
            end do
            newqzmatrix(j, i)=sum2
        end do
    end do

    do i=1, Ns
        do j=1, Ns
            qzmatrix(i, j)=newqzmatrix(i, j)
        end do
    end do

!    do i=1, Ns
!        do j=1, Ns
!            if(abs(qzmatrix(i, j)-qzmatrix(j, i))>=0.00000001) then
!                print *, "e"
!                pause
!            end if
!        end do
!    end do

!---- Write x^2 matrix --------
    do i=1, Ns

        vec_mid2=0.0_Rkind
        do j=1, Nb
            do k=1, Ns
                tmp=0.0_Rkind
                do l=1, Ns
                    tmp=tmp+eigvector(Ns*(j-1)+l ,i)*x2matrix(k ,l)
                end do
                vec_mid2(Ns*(j-1)+k)=tmp
            end do
        end do

        do j=1, Ns

            sum2=0.0_Rkind
            do k=1, Dim
                sum2=sum2+eigvector(k, j)*vec_mid2(k)
            end do
            newx2matrix(j, i)=sum2
        end do
    end do

    do i=1, Ns
        do j=1, Ns
            x2matrix(i, j)=newx2matrix(i, j)
        end do
    end do

!    do i=1, Ns
!        do j=1, Ns
!            if(abs(x2matrix(i, j)-x2matrix(j, i))>=0.00000001) then
!                print *, "e"
!                pause
!            end if
!        end do
!    end do

!---- Write <a+a> matrix --------
    do i=1, Ns

        vec_mid2=0.0_Rkind
        do j=1, Nb
            do k=1, Ns
                tmp=0.0_Rkind
                do l=1, Ns
                    tmp=tmp+eigvector(Ns*(j-1)+l ,i)*nmatrix(k ,l)
                end do
                vec_mid2(Ns*(j-1)+k)=tmp
            end do
        end do

        do j=1, Ns

            sum2=0.0_Rkind
            do k=1, Dim
                sum2=sum2+eigvector(k, j)*vec_mid2(k)
            end do
            newnmatrix(j, i)=sum2
        end do
    end do

    do i=1, Ns
        do j=1, Ns
            nmatrix(i, j)=newnmatrix(i, j)
        end do
    end do

!    do i=1, Ns
!        do j=1, Ns
!            if(abs(nmatrix(i, j)-nmatrix(j, i))>=0.00000001) then
!                print *, "e"
!                pause
!            end if
!        end do
!    end do

!---- Write b0 matrix --------
    do i=1, Ns

        vec_mid2=0.0_Rkind
        do j=1, Nb
            do k=1, Ns
                tmp=0.0_Rkind
                do l=1, Ns
                    tmp=tmp+eigvector(Ns*(j-1)+l ,i)*b0matrixa(k ,l)
                end do
                vec_mid2(Ns*(j-1)+k)=tmp
            end do
        end do

        do j=1, Ns
            sum2=0
            do k=1, Dim
                sum2=sum2+eigvector(k, j)*vec_mid2(k)
            end do
            newb0matrixa(j, i)=sum2
        end do
    end do

    do i=1, Ns
        do j=1, Ns
            b0matrixa(i, j)=newb0matrixa(i, j)
        end do
    end do

!---- Write b0+ matrix --------
    do i=1, Ns

        vec_mid2=0.0_Rkind
        do j=1, Nb
            do k=1, Ns
                tmp=0.0_Rkind
                do l=1, Ns
                    tmp=tmp+eigvector(Ns*(j-1)+l ,i)*b0matrixc(k ,l)
                end do
                vec_mid2(Ns*(j-1)+k)=tmp
            end do
        end do

        do j=1, Ns
            sum2=0.0_Rkind
            do k=1, Dim
                sum2=sum2+eigvector(k, j)*vec_mid2(k)
            end do
            newb0matrixc(j, i)=sum2
        end do
    end do

    do i=1, Ns
        do j=1, Ns
            b0matrixc(i, j)=newb0matrixc(i, j)
        end do
    end do

!    do i=1, Ns
!        do j=1, Ns
!            if(abs(b0matrixa(i, j)-b0matrixc(j, i))>=0.000000001) then
!                print *, "e"
!                pause
!            end if
!        end do
!    end do

    end subroutine diag_Hn

!========+=========+=========+=========+=========+=========+=========+=$
! PROGRAM: RS_CPU
! NOTICE :
! TYPE   : subroutine
! PURPOSE: This code use the same interface as RS() (in slatec), but
!          actually called the Lapack code "dsyev()" to diagonalize
!          the real symmetric matrix.
! I/O    :
! VERSION: 26-Dec-2012
! AUTHOR : Q. S. Wu
! COMMENT: I got it from Quan-Shen Wu.
!========+=========+=========+=========+=========+=========+=========+=$
      SUBROUTINE RS_cpu (NM, N, A, W, MATZ, Z, FV1, FV2, IERR)

         use prec
         implicit none

         !>> inout variables
         integer,intent(IN):: N, NM, MATZ
         integer,intent(OUT):: IERR
         real(kind=rkind),dimension(NM,NM),intent(IN):: A
         real(kind=rkind),dimension(NM,N),intent(OUT)::Z
         real(kind=rkind),dimension(N),intent(OUT)::W
         real(kind=rkind),dimension(N),intent(IN)::FV1,FV2

         !>> local variables
         integer :: i
         real(kind=rkind),allocatable :: ham(:, :)

         allocate(ham(N, N))

         ham= A(1:N, 1:N)

         call eigensystem_r('V', 'U', N, ham, W)

         Z(1:N, 1:N)= ham

         ierr=0

         return
      end subroutine rs_cpu
!========+=========+=========+=========+=========+=========+=========+=$

!========+=========+=========+=========+=========+=========+=========+=$
! PROGRAM: eigensystem_r
! NOTICE :
! TYPE   : subroutine
! PURPOSE: This code encapsulate the Lapack code "dsyev()" for diagonalizing
!          real symmetric matrix and prudce eigen values and eigen vectors.
! I/O    :
! VERSION: 26-Dec-2012
! AUTHOR : Q. S. Wu
! COMMENT: I got it from Quan-Shen Wu.
!========+=========+=========+=========+=========+=========+=========+=$
! real version on cpu
! a subroutine to calculate eigenvector and eigenvalue
  subroutine eigensystem_r(JOBZ,UPLO,N,A,W)

!    use param, only : Rkind
     implicit none

     integer, parameter :: Rkind=8
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
     character*1, intent(in) :: JOBZ

!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
     character*1, intent(in) :: UPLO

!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
     integer,   intent(in) :: N

!  A       (input/output) COMPLEX*16 array, dimension (LDA, N)
!          On entry, the Hermitian matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
!          orthonormal eigenvectors of the matrix A.
!          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
!          or the upper triangle (if UPLO='U') of A, including the
!          diagonal, is destroyed.

     real(Rkind),intent(inout) :: A(N,N)

!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.

     real(Rkind), intent(inout) :: W(N)

     integer :: info

     integer :: lwork

     real(Rkind),allocatable ::  rwork(:)

     real(Rkind),allocatable :: work(:)

     lwork= 16*N
     allocate(rwork(lwork))
     allocate( work(lwork))

     W= 0.0d0
     info= 0
     call dsyev( JOBZ, UPLO, N, A, N,  &
              W, work, lwork, rwork, info )

     return
  end subroutine
!========+=========+=========+=========+=========+=========+=========+=$


      SUBROUTINE SLARRE2A( RANGE, N, VL, VU, IL, IU, D, E, E2,
     $                    RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT,
     $                    M, DOL, DOU, NEEDIL, NEEDIU,
     $                    W, WERR, WGAP, IBLOCK, INDEXW, GERS,
     $                    SDIAM, PIVMIN, WORK, IWORK, MINRGP, INFO )
*
*  -- ScaLAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
*     July 4, 2010
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      CHARACTER          RANGE
      INTEGER            DOL, DOU, IL, INFO, IU, M, N, NSPLIT,
     $                   NEEDIL, NEEDIU
      REAL               MINRGP, PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * ),
     $                   INDEXW( * )
      REAL               D( * ), E( * ), E2( * ), GERS( * ),
     $                   SDIAM( * ), W( * ),WERR( * ),
     $                   WGAP( * ), WORK( * )
*
*  Purpose
*  =======
*
*  To find the desired eigenvalues of a given real symmetric
*  tridiagonal matrix T, SLARRE2 sets any "small" off-diagonal
*  elements to zero, and for each unreduced block T_i, it finds
*  (a) a suitable shift at one end of the block's spectrum,
*  (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
*  (c) eigenvalues of each L_i D_i L_i^T.
*
*  NOTE:
*  The algorithm obtains a crude picture of all the wanted eigenvalues
*  (as selected by RANGE). However, to reduce work and improve scalability,
*  only the eigenvalues DOL to DOU are refined. Furthermore, if the matrix
*  splits into blocks, RRRs for blocks that do not contain eigenvalues
*  from DOL to DOU are skipped.
*  The DQDS algorithm (subroutine SLASQ2) is not used, unlike in
*  the sequential case. Instead, eigenvalues are computed in parallel to some
*  figures using bisection.

*
*  Arguments
*  =========
*
*  RANGE   (input) CHARACTER
*          = 'A': ("All")   all eigenvalues will be found.
*          = 'V': ("Value") all eigenvalues in the half-open interval
*                           (VL, VU] will be found.
*          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
*                           entire matrix) will be found.
*
*  N       (input) INTEGER
*          The order of the matrix. N > 0.
*
*  VL      (input/output) REAL
*  VU      (input/output) REAL
*          If RANGE='V', the lower and upper bounds for the eigenvalues.
*          Eigenvalues less than or equal to VL, or greater than VU,
*          will not be returned.  VL < VU.
*          If RANGE='I' or ='A', SLARRE2A computes bounds on the desired
*          part of the spectrum.
*
*  IL      (input) INTEGER
*  IU      (input) INTEGER
*          If RANGE='I', the indices (in ascending order) of the
*          smallest and largest eigenvalues to be returned.
*          1 <= IL <= IU <= N.
*
*  D       (input/output) REAL             array, dimension (N)
*          On entry, the N diagonal elements of the tridiagonal
*          matrix T.
*          On exit, the N diagonal elements of the diagonal
*          matrices D_i.
*
*  E       (input/output) REAL             array, dimension (N)
*          On entry, the first (N-1) entries contain the subdiagonal
*          elements of the tridiagonal matrix T; E(N) need not be set.
*          On exit, E contains the subdiagonal elements of the unit
*          bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
*          1 <= I <= NSPLIT, contain the base points sigma_i on output.
*
*  E2      (input/output) REAL             array, dimension (N)
*          On entry, the first (N-1) entries contain the SQUARES of the
*          subdiagonal elements of the tridiagonal matrix T;
*          E2(N) need not be set.
*          On exit, the entries E2( ISPLIT( I ) ),
*          1 <= I <= NSPLIT, have been set to zero
*
*  RTOL1   (input) REAL
*  RTOL2   (input) REAL
*           Parameters for bisection.
*           An interval [LEFT,RIGHT] has converged if
*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
*
*  SPLTOL (input) REAL
*          The threshold for splitting.
*
*  NSPLIT  (output) INTEGER
*          The number of blocks T splits into. 1 <= NSPLIT <= N.
*
*  ISPLIT  (output) INTEGER array, dimension (N)
*          The splitting points, at which T breaks up into blocks.
*          The first block consists of rows/columns 1 to ISPLIT(1),
*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
*          etc., and the NSPLIT-th consists of rows/columns
*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*
*  M       (output) INTEGER
*          The total number of eigenvalues (of all L_i D_i L_i^T)
*          found.
*
*  DOL     (input) INTEGER
*  DOU     (input) INTEGER
*          If the user wants to work on only a selected part of the
*          representation tree, he can specify an index range DOL:DOU.
*          Otherwise, the setting DOL=1, DOU=N should be applied.
*          Note that DOL and DOU refer to the order in which the eigenvalues
*          are stored in W.
*
*  NEEDIL  (output) INTEGER
*  NEEDIU  (output) INTEGER
*          The indices of the leftmost and rightmost eigenvalues
*          of the root node RRR which are
*          needed to accurately compute the relevant part of the
*          representation tree.
*
*  W       (output) REAL             array, dimension (N)
*          The first M elements contain the eigenvalues. The
*          eigenvalues of each of the blocks, L_i D_i L_i^T, are
*          sorted in ascending order ( SLARRE2A may use the
*          remaining N-M elements as workspace).
*          Note that immediately after exiting this routine, only
*          the eigenvalues from position DOL:DOU in W are
*          reliable on this processor
*          because the eigenvalue computation is done in parallel.
*
*  WERR    (output) REAL             array, dimension (N)
*          The error bound on the corresponding eigenvalue in W.
*          Note that immediately after exiting this routine, only
*          the uncertainties from position DOL:DOU in WERR are
*          reliable on this processor
*          because the eigenvalue computation is done in parallel.
*
*  WGAP    (output) REAL             array, dimension (N)
*          The separation from the right neighbor eigenvalue in W.
*          The gap is only with respect to the eigenvalues of the same block
*          as each block has its own representation tree.
*          Exception: at the right end of a block we store the left gap
*          Note that immediately after exiting this routine, only
*          the gaps from position DOL:DOU in WGAP are
*          reliable on this processor
*          because the eigenvalue computation is done in parallel.
*
*  IBLOCK  (output) INTEGER array, dimension (N)
*          The indices of the blocks (submatrices) associated with the
*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
*          W(i) belongs to the first block from the top, =2 if W(i)
*          belongs to the second block, etc.
*
*  INDEXW  (output) INTEGER array, dimension (N)
*          The indices of the eigenvalues within each block (submatrix);
*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
*          i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
*
*  GERS    (output) REAL             array, dimension (2*N)
*          The N Gerschgorin intervals (the i-th Gerschgorin interval
*          is (GERS(2*i-1), GERS(2*i)).
*
*  PIVMIN  (output) DOUBLE PRECISION
*          The minimum pivot in the sturm sequence for T.
*
*  WORK    (workspace) REAL             array, dimension (6*N)
*          Workspace.
*
*  IWORK   (workspace) INTEGER array, dimension (5*N)
*          Workspace.
*
*  MINRGP  (input) REAL
*          The minimum relativ gap threshold to decide whether an eigenvalue
*          or a cluster boundary is reached.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          > 0:  A problem occured in SLARRE2A.
*          < 0:  One of the called subroutines signaled an internal problem.
*                Needs inspection of the corresponding parameter IINFO
*                for further information.
*
*          =-1:  Problem in SLARRD2.
*          = 2:  No base representation could be found in MAXTRY iterations.
*                Increasing MAXTRY and recompilation might be a remedy.
*          =-3:  Problem in SLARRB2 when computing the refined root
*                representation
*          =-4:  Problem in SLARRB2 when preforming bisection on the
*                desired part of the spectrum.
*          = -9  Problem: M < DOU-DOL+1, that is the code found fewer
*                eigenvalues than it was supposed to
*
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
     $                   MAXGROWTH, ONE, PERT, TWO, ZERO
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
     $                     TWO = 2.0E0, FOUR=4.0E0,
     $                     HNDRD = 100.0E0,
     $                     PERT = 4.0E0,
     $                     HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
     $                     MAXGROWTH = 64.0E0, FUDGE = 2.0E0 )
      INTEGER            MAXTRY
      PARAMETER          ( MAXTRY = 6 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOREP, RNDPRT, USEDQD
      INTEGER            CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
     $                   IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
     $                   MYINDL, MYINDU, MYWBEG, MYWEND, WBEGIN, WEND
      REAL               AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
     $                   EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT,
     $                   LGPVMN, LGSPDM, RTL, S1, S2, SAFMIN, SGNDEF,
     $                   SIGMA, SPDIAM, TAU, TMP, TMP1, TMP2

*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL                        SLAMCH
      EXTERNAL           SLAMCH, LSAME

*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SLARNV, SLARRA, SLARRB2,
     $                   SLARRC, SLARRD2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN

*     ..
*     .. Executable Statements ..
*

      INFO = 0

*     Dis-/Enable a small random perturbation of the root representation
      RNDPRT = .TRUE.
*
*     Decode RANGE
*
      IF( LSAME( RANGE, 'A' ) ) THEN
         IRANGE = 1
      ELSE IF( LSAME( RANGE, 'V' ) ) THEN
         IRANGE = 2
      ELSE IF( LSAME( RANGE, 'I' ) ) THEN
         IRANGE = 3
      END IF

      M = 0

*     Get machine constants
      SAFMIN = SLAMCH( 'S' )
      EPS = SLAMCH( 'P' )

*     Set parameters
      RTL = HNDRD*EPS
      BSRTOL =  1.0E-1

*     Treat case of 1x1 matrix for quick return
      IF( N.EQ.1 ) THEN
         IF( (IRANGE.EQ.1).OR.
     $       ((IRANGE.EQ.2).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
     $       ((IRANGE.EQ.3).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
            M = 1
            W(1) = D(1)
*           The computation error of the eigenvalue is zero
            WERR(1) = ZERO
            WGAP(1) = ZERO
            IBLOCK( 1 ) = 1
            INDEXW( 1 ) = 1
            GERS(1) = D( 1 )
            GERS(2) = D( 1 )
         ENDIF
*        store the shift for the initial RRR, which is zero in this case
         E(1) = ZERO
         RETURN
      END IF

*     General case: tridiagonal matrix of order > 1

*     Init WERR, WGAP.
      DO 1 I =1,N
         WERR(I) = ZERO
 1    CONTINUE
      DO 2 I =1,N
         WGAP(I) = ZERO
 2    CONTINUE

*     Compute Gerschgorin intervals and spectral diameter.
*     Compute maximum off-diagonal entry and pivmin.
      GL = D(1)
      GU = D(1)
      EOLD = ZERO
      EMAX = ZERO
      E(N) = ZERO
      DO 5 I = 1,N
         EABS = ABS( E(I) )
         IF( EABS .GE. EMAX ) THEN
            EMAX = EABS
         END IF
         TMP = EABS + EOLD
         EOLD  = EABS
         TMP1 = D(I) - TMP
         TMP2 = D(I) + TMP
         GL = MIN( GL, TMP1 )
         GU = MAX( GU, TMP2 )
         GERS( 2*I-1) = TMP1
         GERS( 2*I ) = TMP2
 5    CONTINUE
*     The minimum pivot allowed in the sturm sequence for T
      PIVMIN = SAFMIN * MAX( ONE, EMAX**2 )
*     Compute spectral diameter. The Gerschgorin bounds give an
*     estimate that is wrong by at most a factor of SQRT(2)
      SPDIAM = GU - GL

*     Compute splitting points
      CALL SLARRA( N, D, E, E2, SPLTOL, SPDIAM,
     $                    NSPLIT, ISPLIT, IINFO )

      IF( IRANGE.EQ.1 ) THEN
*        Set interval [VL,VU] that contains all eigenvalues
         VL = GL
         VU = GU
      ENDIF

*     We call SLARRD2 to find crude approximations to the eigenvalues
*     in the desired range. In case IRANGE = 3, we also obtain the
*     interval (VL,VU] that contains all the wanted eigenvalues.
*     An interval [LEFT,RIGHT] has converged if
*     RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
*     SLARRD2 needs a WORK of size 4*N, IWORK of size 3*N
      CALL SLARRD2( RANGE, 'B', N, VL, VU, IL, IU, GERS,
     $                 BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
     $                 MM, W, WERR, VL, VU, IBLOCK, INDEXW,
     $                 WORK, IWORK, DOL, DOU, IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = -1
         RETURN
      ENDIF
*     Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
      DO 14 I = MM+1,N
         W( I ) = ZERO
         WERR( I ) = ZERO
         IBLOCK( I ) = 0
         INDEXW( I ) = 0
 14   CONTINUE

***
*     Loop over unreduced blocks
      IBEGIN = 1
      WBEGIN = 1
      DO 170 JBLK = 1, NSPLIT
         IEND = ISPLIT( JBLK )
         IN = IEND - IBEGIN + 1

*        1 X 1 block
         IF( IN.EQ.1 ) THEN
            IF( (IRANGE.EQ.1).OR.( (IRANGE.EQ.2).AND.
     $         ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
     $        .OR. ( (IRANGE.EQ.3).AND.(IBLOCK(WBEGIN).EQ.JBLK))
     $        ) THEN
               M = M + 1
               W( M ) = D( IBEGIN )
               WERR(M) = ZERO
*              The gap for a single block doesn't matter for the later
*              algorithm and is assigned an arbitrary large value
               WGAP(M) = ZERO
               IBLOCK( M ) = JBLK
               INDEXW( M ) = 1
               WBEGIN = WBEGIN + 1
            ENDIF
*           E( IEND ) holds the shift for the initial RRR
            E( IEND ) = ZERO
            IBEGIN = IEND + 1
            GO TO 170
         END IF
*
*        Blocks of size larger than 1x1
*
*        E( IEND ) will hold the shift for the initial RRR, for now set it =0
         E( IEND ) = ZERO

         IF( ( IRANGE.EQ.1 ) .OR.
     $       ((IRANGE.EQ.3).AND.(IL.EQ.1.AND.IU.EQ.N)) ) THEN
*           MB =  number of eigenvalues to compute
            MB = IN
            WEND = WBEGIN + MB - 1
            INDL = 1
            INDU = IN
         ELSE
*           Count the number of eigenvalues in the current block.
            MB = 0
            DO 20 I = WBEGIN,MM
               IF( IBLOCK(I).EQ.JBLK ) THEN
                  MB = MB+1
               ELSE
                  GOTO 21
               ENDIF
 20         CONTINUE
 21         CONTINUE

            IF( MB.EQ.0) THEN
*              No eigenvalue in the current block lies in the desired range
*              E( IEND ) holds the shift for the initial RRR
               E( IEND ) = ZERO
               IBEGIN = IEND + 1
               GO TO 170
            ENDIF
*
            WEND = WBEGIN + MB - 1
*           Find local index of the first and last desired evalue.
            INDL = INDEXW(WBEGIN)
            INDU = INDEXW( WEND )
	 ENDIF
*
         IF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
*           if this subblock contains no desired eigenvalues,
*           skip the computation of this representation tree
            IBEGIN = IEND + 1
            WBEGIN = WEND + 1
            M = M + MB
            GO TO 170
         END IF
*
         IF(.NOT. ( IRANGE.EQ.1 ) ) THEN

*           At this point, the sequential code decides
*	    whether dqds or bisection is more efficient.
*           Note: in the parallel code, we do not use dqds.
*           However, we do not change the shift strategy
*           if USEDQD is TRUE, then the same shift is used as for
*           the sequential code when it uses dqds.
*
            USEDQD = ( MB .GT. FAC*IN )
*
*           Calculate gaps for the current block
*           In later stages, when representations for individual
*           eigenvalues are different, we use SIGMA = E( IEND ).
            SIGMA = ZERO
            DO 30 I = WBEGIN, WEND - 1
               WGAP( I ) = MAX( ZERO,
     $                     W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
 30         CONTINUE
            WGAP( WEND ) = MAX( ZERO,
     $                  VU - SIGMA - (W( WEND )+WERR( WEND )))
         ENDIF

*
*        Find local outer bounds GL,GU for the block
         GL = D(IBEGIN)
         GU = D(IBEGIN)
         DO 15 I = IBEGIN , IEND
            GL = MIN( GERS( 2*I-1 ), GL )
            GU = MAX( GERS( 2*I ), GU )
 15      CONTINUE
         SPDIAM = GU - GL
*        Save local spectral diameter for later use
         SDIAM(JBLK) = SPDIAM

*        Find approximations to the extremal eigenvalues of the block
         CALL SLARRK( IN, 1, GL, GU, D(IBEGIN),
     $               E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = -1
            RETURN
         ENDIF
         ISLEFT = MAX(GL, TMP - TMP1
     $            - HNDRD * EPS* ABS(TMP - TMP1))
         CALL SLARRK( IN, IN, GL, GU, D(IBEGIN),
     $               E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = -1
            RETURN
         ENDIF
         ISRGHT = MIN(GU, TMP + TMP1
     $                 + HNDRD * EPS * ABS(TMP + TMP1))
         IF( ( IRANGE.EQ.1 ).OR.USEDQD ) THEN
*           Case of DQDS shift
*           Improve the estimate of the spectral diameter
            SPDIAM = ISRGHT - ISLEFT
         ELSE
*           Case of bisection
*           Find approximations to the wanted extremal eigenvalues
            ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN)
     $                  - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) ))
            ISRGHT = MIN(GU,W(WEND) + WERR(WEND)
     $                  + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND)))
	 ENDIF

*        Decide whether the base representation for the current block
*        L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
*        should be on the left or the right end of the current block.
*        The strategy is to shift to the end which is "more populated"
         IF( IRANGE.EQ.1 ) THEN
*           If all the eigenvalues have to be computed, we use dqd
            USEDQD = .TRUE.
*           INDL is the local index of the first eigenvalue to compute
            INDL = 1
            INDU = IN
*           MB =  number of eigenvalues to compute
            MB = IN
            WEND = WBEGIN + MB - 1
*           Define 1/4 and 3/4 points of the spectrum
            S1 = ISLEFT + FOURTH * SPDIAM
	    S2 = ISRGHT - FOURTH * SPDIAM
         ELSE
*           SLARRD2 has computed IBLOCK and INDEXW for each eigenvalue
*           approximation.
*           choose sigma
            IF( USEDQD ) THEN
               S1 = ISLEFT + FOURTH * SPDIAM
	       S2 = ISRGHT - FOURTH * SPDIAM
            ELSE
               TMP = MIN(ISRGHT,VU) -  MAX(ISLEFT,VL)
               S1 =  MAX(ISLEFT,VL) + FOURTH * TMP
               S2 =  MIN(ISRGHT,VU) - FOURTH * TMP
            ENDIF
         ENDIF

*        Compute the negcount at the 1/4 and 3/4 points
         IF(MB.GT.2) THEN
	    CALL SLARRC( 'T', IN, S1, S2, D(IBEGIN),
     $                    E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
         ENDIF

	 IF(MB.LE.2) THEN
            SIGMA = GL
            SGNDEF = ONE
         ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
            IF( IRANGE.EQ.1 ) THEN
               SIGMA = MAX(ISLEFT,GL)
            ELSEIF( USEDQD ) THEN
*              use Gerschgorin bound as shift to get pos def matrix
               SIGMA = ISLEFT
            ELSE
*              use approximation of the first desired eigenvalue of the
*              block as shift
               SIGMA = MAX(ISLEFT,VL)
            ENDIF
            SGNDEF = ONE
         ELSE
            IF( IRANGE.EQ.1 ) THEN
               SIGMA = MIN(ISRGHT,GU)
            ELSEIF( USEDQD ) THEN
*              use Gerschgorin bound as shift to get neg def matrix
*              for dqds
               SIGMA = ISRGHT
            ELSE
*              use approximation of the first desired eigenvalue of the
*              block as shift
               SIGMA = MIN(ISRGHT,VU)
            ENDIF
            SGNDEF = -ONE
         ENDIF

*        An initial SIGMA has been chosen that will be used for computing
*        T - SIGMA I = L D L^T
*        Define the increment TAU of the shift in case the initial shift
*        needs to be refined to obtain a factorization with not too much
*        element growth.
         IF( USEDQD ) THEN
            TAU = SPDIAM*EPS*N + TWO*PIVMIN
            TAU = MAX(TAU,EPS*ABS(SIGMA))
         ELSE
            IF(MB.GT.1) THEN
               CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
               AVGAP = ABS(CLWDTH / REAL(WEND-WBEGIN))
               IF( SGNDEF.EQ.ONE ) THEN
                  TAU = HALF*MAX(WGAP(WBEGIN),AVGAP)
                  TAU = MAX(TAU,WERR(WBEGIN))
               ELSE
                  TAU = HALF*MAX(WGAP(WEND-1),AVGAP)
                  TAU = MAX(TAU,WERR(WEND))
               ENDIF
	    ELSE
               TAU = WERR(WBEGIN)
	    ENDIF
         ENDIF
*
         DO 80 IDUM = 1, MAXTRY
*           Compute L D L^T factorization of tridiagonal matrix T - sigma I.
*           Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
*           pivots in WORK(2*IN+1:3*IN)
            DPIVOT = D( IBEGIN ) - SIGMA
            WORK( 1 ) = DPIVOT
            DMAX = ABS( WORK(1) )
            J = IBEGIN
            DO 70 I = 1, IN - 1
               WORK( 2*IN+I ) = ONE / WORK( I )
               TMP = E( J )*WORK( 2*IN+I )
               WORK( IN+I ) = TMP
               DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J )
               WORK( I+1 ) = DPIVOT
               DMAX = MAX( DMAX, ABS(DPIVOT) )
               J = J + 1
 70         CONTINUE
*           check for element growth
            IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN
               NOREP = .TRUE.
	    ELSE
               NOREP = .FALSE.
            ENDIF
	    IF(NOREP) THEN
*              Note that in the case of IRANGE=1, we use the Gerschgorin
*              shift which makes the matrix definite. So we should end up
*              here really only in the case of IRANGE = 2,3
               IF( IDUM.EQ.MAXTRY-1 ) THEN
                  IF( SGNDEF.EQ.ONE ) THEN
*                    The fudged Gerschgorin shift should succeed
                     SIGMA =
     $                    GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN
                  ELSE
                     SIGMA =
     $                    GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN
                  END IF
               ELSE
                  SIGMA = SIGMA - SGNDEF * TAU
                  TAU = TWO * TAU
               END IF
            ELSE
*              an initial RRR is found
               GO TO 83
            END IF
 80      CONTINUE
*        if the program reaches this point, no base representation could be
*        found in MAXTRY iterations.
         INFO = 2
         RETURN

 83      CONTINUE
*        At this point, we have found an initial base representation
*        T - SIGMA I = L D L^T with not too much element growth.
*        Store the shift.
         E( IEND ) = SIGMA
*        Store D and L.
         CALL SCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
         CALL SCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )

         IF(RNDPRT .AND. MB.GT.1 ) THEN
*
*           Perturb each entry of the base representation by a small
*           (but random) relative amount to overcome difficulties with
*           glued matrices.
*
            DO 122 I = 1, 4
               ISEED( I ) = 1
 122        CONTINUE

            CALL SLARNV(2, ISEED, 2*IN-1, WORK(1))
            DO 125 I = 1,IN-1
               D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(2*I-1))
               E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(2*I))
 125        CONTINUE
            D(IEND) = D(IEND)*(ONE+EPS*PERT*WORK(2*IN-1))
*
         ENDIF
*
*        Compute the required eigenvalues of L D L' by bisection
*        Shift the eigenvalue approximations
*        according to the shift of their representation.
         DO 134 J=WBEGIN,WEND
            W(J) = W(J) - SIGMA
            WERR(J) = WERR(J) + ABS(W(J)) * EPS
 134     CONTINUE
*        call SLARRB2 to reduce eigenvalue error of the approximations
*        from SLARRD2
         DO 135 I = IBEGIN, IEND-1
            WORK( I ) = D( I ) * E( I )**2
 135     CONTINUE
*        use bisection to find EV from INDL to INDU
         INDL = INDEXW( WBEGIN )
         INDU = INDEXW( WEND )
*
*        Indicate that the current block contains eigenvalues that
*        are potentially needed later.
*
         NEEDIL = MIN(NEEDIL,WBEGIN)
         NEEDIU = MAX(NEEDIU,WEND)
*
*        For the parallel distributed case, only compute
*        those eigenvalues that have to be computed as indicated by DOL, DOU
*
         MYWBEG = MAX(WBEGIN,DOL)
         MYWEND = MIN(WEND,DOU)
*
         IF(MYWBEG.GT.WBEGIN) THEN
*           This is the leftmost block containing wanted eigenvalues
*           as well as unwanted ones. To save on communication,
*           check if NEEDIL can be increased even further:
*           on the left end, only the eigenvalues of the cluster
*           including MYWBEG are needed
            DO 136 I = WBEGIN, MYWBEG-1
               IF ( WGAP(I).GE.MINRGP*ABS(W(I)) ) THEN
                  NEEDIL = MAX(I+1,NEEDIL)
               ENDIF
 136        CONTINUE
         ENDIF
         IF(MYWEND.LT.WEND) THEN
*           This is the rightmost block containing wanted eigenvalues
*           as well as unwanted ones. To save on communication,
*           Check if NEEDIU can be decreased even further.
            DO 137 I = MYWEND,WEND-1
               IF ( WGAP(I).GE.MINRGP*ABS(W(I)) ) THEN
                  NEEDIU = MIN(I,NEEDIU)
                  GOTO 138
               ENDIF
 137        CONTINUE
 138        CONTINUE
         ENDIF
*
*        Only compute eigenvalues from MYINDL to MYINDU
*        instead of INDL to INDU
*
         MYINDL = INDEXW( MYWBEG )
         MYINDU = INDEXW( MYWEND )
*
         LGPVMN = LOG( PIVMIN )
         LGSPDM = LOG( SPDIAM + PIVMIN )

         CALL SLARRB2(IN, D(IBEGIN), WORK(IBEGIN),
     $               MYINDL, MYINDU, RTOL1, RTOL2, MYINDL-1,
     $               W(MYWBEG), WGAP(MYWBEG), WERR(MYWBEG),
     $               WORK( 2*N+1 ), IWORK, PIVMIN,
     $               LGPVMN, LGSPDM, IN, IINFO )
         IF( IINFO .NE. 0 ) THEN
            INFO = -4
            RETURN
         END IF
*        SLARRB2 computes all gaps correctly except for the last one
*        Record distance to VU/GU
         WGAP( WEND ) = MAX( ZERO,
     $           ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) )
         DO 140 I = INDL, INDU
            M = M + 1
            IBLOCK(M) = JBLK
            INDEXW(M) = I
 140     CONTINUE
*
*        proceed with next block
         IBEGIN = IEND + 1
         WBEGIN = WEND + 1
 170  CONTINUE
*
      IF (M.LT.DOU-DOL+1) THEN
         INFO = -9
      ENDIF

      RETURN
*
*     end of SLARRE2A
*
      END


      SUBROUTINE SLAE2( A, B, C, RT1, RT2 )
*
*  -- LAPACK auxiliary routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      REAL               A, B, C, RT1, RT2
*     ..
*
*  Purpose
*  =======
*
*  SLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix
*     [  A   B  ]
*     [  B   C  ].
*  On return, RT1 is the eigenvalue of larger absolute value, and RT2
*  is the eigenvalue of smaller absolute value.
*
*  Arguments
*  =========
*
*  A       (input) REAL
*          The (1,1) element of the 2-by-2 matrix.
*
*  B       (input) REAL
*          The (1,2) and (2,1) elements of the 2-by-2 matrix.
*
*  C       (input) REAL
*          The (2,2) element of the 2-by-2 matrix.
*
*  RT1     (output) REAL
*          The eigenvalue of larger absolute value.
*
*  RT2     (output) REAL
*          The eigenvalue of smaller absolute value.
*
*  Further Details
*  ===============
*
*  RT1 is accurate to a few ulps barring over/underflow.
*
*  RT2 may be inaccurate if there is massive cancellation in the
*  determinant A*C-B*B; higher precision or correctly rounded or
*  correctly truncated arithmetic would be needed to compute RT2
*  accurately in all cases.
*
*  Overflow is possible only if RT1 is within a factor of 5 of overflow.
*  Underflow is harmless if the input data is 0 or exceeds
*     underflow_threshold / macheps.
*
* =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E0 )
      REAL               TWO
      PARAMETER          ( TWO = 2.0E0 )
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
      REAL               HALF
      PARAMETER          ( HALF = 0.5E0 )
*     ..
*     .. Local Scalars ..
      REAL               AB, ACMN, ACMX, ADF, DF, RT, SM, TB
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
*     ..
*     .. Executable Statements ..
*
*     Compute the eigenvalues
*
      SM = A + C
      DF = A - C
      ADF = ABS( DF )
      TB = B + B
      AB = ABS( TB )
      IF( ABS( A ).GT.ABS( C ) ) THEN
         ACMX = A
         ACMN = C
      ELSE
         ACMX = C
         ACMN = A
      END IF
      IF( ADF.GT.AB ) THEN
         RT = ADF*SQRT( ONE+( AB / ADF )**2 )
      ELSE IF( ADF.LT.AB ) THEN
         RT = AB*SQRT( ONE+( ADF / AB )**2 )
      ELSE
*
*        Includes case AB=ADF=0
*
         RT = AB*SQRT( TWO )
      END IF
      IF( SM.LT.ZERO ) THEN
         RT1 = HALF*( SM-RT )
*
*        Order of execution important.
*        To get fully accurate smaller eigenvalue,
*        next line needs to be executed in higher precision.
*
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE IF( SM.GT.ZERO ) THEN
         RT1 = HALF*( SM+RT )
*
*        Order of execution important.
*        To get fully accurate smaller eigenvalue,
*        next line needs to be executed in higher precision.
*
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE
*
*        Includes case RT1 = RT2 = 0
*
         RT1 = HALF*RT
         RT2 = -HALF*RT
      END IF
      RETURN
*
*     End of SLAE2
*
      END


program SimLensCMBtry
 use HealpixObj
 use HealpixVis
 use Random
 use spinalm_tools
 use IniFile
 use AMLUtils
 implicit none
 Type(HealpixInfo)  :: H
 Type(HealpixMap)   :: M, GradPhi
 Type(HealpixPower) :: P
 Type(HealpixAlm)   :: A

 integer            :: nside, lmax
 integer(I_NPIX)    :: npix
 character(LEN=256)  :: w8name = '../Healpix_2.00/data/'
 character(LEN=256)  :: file_stem, cls_file, out_file_root, cls_lensed_file
 integer, parameter :: lens_interp =1, lens_exact = 2
 integer :: lens_method = lens_interp
 integer :: mpi_division_method = division_equalrows
 integer ::  interp_method,  rand_seed
 logical :: err, want_pol
 real :: interp_factor
#ifdef MPIPIX
 integer i

 call mpi_init(i)
#endif

 Ini_Fail_On_Not_Found = .true.
 call Ini_Open(GetParam(1), 3,err)
 if (err) then
#ifdef MPIPIX
    call mpi_finalize(i)
#endif
   stop 'No ini'
 end if
 nside  = Ini_Read_Int('nside')
 npix = nside2npix(nside)

 lmax   = Ini_Read_Int('lmax')
 cls_file = Ini_Read_String('cls_file')
 x out_file_root = Ini_Read_String('out_file_root')

 want_pol = Ini_Read_Logical('want_pol')
 rand_seed = Ini_Read_Int('rand_seed')

 interp_method = Ini_read_int('interp_method')

 Ini_Fail_On_Not_Found = .false.

 w8name = Ini_Read_String('w8dir')
 interp_factor=0
 if (lens_method == lens_interp) interp_factor = Ini_Read_Real('interp_factor',3.)
#ifdef MPIPIX
 mpi_division_method = Ini_Read_Int('mpi_division_method',division_balanced);
#endif

 call Ini_Close

 file_stem =  trim(out_file_root)//'_lmax'//trim(IntToStr(lmax))//'_nside'//trim(IntTOStr(nside))// &
              '_interp'//trim(RealToStr(interp_factor,3))//'_method'//trim(IntToStr(interp_method))//'_'

 if (want_pol) file_stem=trim(file_stem)//'pol_'
 file_stem = trim(file_stem)//trim(IntToStr(lens_method))

 cls_lensed_file  = trim(file_stem)//'.dat'

 call SetIdlePriority();

!Healpix 2.01 has up to 8192
! if (nside > 1024) then
 if (w8name=='') then
  write (*,*) 'Warning: using unit weights as no w8dir specified'
  call HealpixInit(H,nside, lmax,.true., w8dir='', method= mpi_division_method)
 else
  call HealpixInit(H,nside, lmax,.true., w8dir=w8name,method=mpi_division_method)
 end if

 if (H%MpiID ==0) then !if we are main thread
  !All but main thread stay in HealpixInit

  call HealpixPower_nullify(P)
  call HealpixAlm_nullify(A)
  call HealpixMap_nullify(GradPhi)
  call HealpixMap_nullify(M)

  call HealpixPower_ReadFromTextFile(P,cls_file,lmax,pol=.true.,dolens = .true.)
  !Reads in unlensed C_l text files as produced by CAMB (or CMBFAST if you aren't doing lensing)
  call HealpixPower_ReadFromTextFile(P,cls_file,lmax,pol=.true.,dolens = .true.)
  !Reads in unlensed C_l text files as produced by CAMB (or CMBFAST if you aren't doing lensing)

  call HealpixAlm_Sim(A, P, rand_seed,HasPhi=.true., dopol = want_pol)
  call HealpixAlm2Power(A,P)
  call HealpixPower_Write(P,trim(file_stem)//'_unlensed_simulated.dat')

END PROGRAM SimLensCMBtry