*
      PROGRAM PCGSTS
***********************************************************************
*   SAMPLE PROGRAM FOR ROUTINE PCGS.                VER. 1            *
***********************************************************************
       IMPLICIT REAL*8(A-H,O-Z)
       DIMENSION A(100,20),B(100),X(0:100),DD(0:100),W(0:100),D(100)
     *  ,P(0:100),Q(0:100),R(0:100),R0(100),E(100),H(100),M(200)
     *  ,IA(100,20)
C
      N=10
      NL=3
      S=0.0D0
      L=100
    5 ITR=50
      EPS=1.0D-7
      DO 10 J=1,2*NL
       DO 10 I=1,N
        IA(I,J)=0
   10   A(I,J)=0.0D0
      DO 15 I=1,N
   15  X(I)=0.0D0
      B(1)=20.0D0
      B(2)=23.0D0
      B(3)=23.0D0
      B(4)=25.0D0
      B(5)=24.0D0
      B(6)=24.0D0
      B(7)=25.0D0
      B(8)=23.0D0
      B(9)=23.0D0
      B(10)=20.0D0
      DO 20 I=1,N
   20  D(I)=14.0D0
      DO 30 I=2,N
       A(I-1,4)=3.0D0
       IA(I-1,4)=I
       IA(I,1)=I-1
   30  A(I,1)=3.0D0
      DO 40 I=4,N
       A(I-3,5)=2.0D0
       IA(I-3,5)=I
       IA(I,2)=I-3
   40  A(I,2)=2.0D0
      DO 50 I=7,N
       A(I-6,6)=1.0D0
       IA(I-6,6)=I
       IA(I,3)=I-6
   50  A(I,3)=1.0D0
      CALL PCGS(D,A,IA,N,L,NL,B,EPS,ITR,S,X,DD,P,Q,R,R0,E,H,W,M,IER)
      WRITE(*,*) 'EXAMPLE OF PCGS. ', ITR, EPS, S
      WRITE(*,*) (X(I),I=1,N)
      IF ( S .EQ. 0.0) THEN
       S=0.95D0
       GO TO 5
      ENDIF
      IF (S .LT. 1.0) THEN
       S=1.02D0
       GO TO 5
      ENDIF
      IF (S .GT. 1.0) THEN
       S = 1.0D0
       GO TO 5
      ENDIF
      STOP
      END


! ============================ Module Description ===========================
! PHI_MOD: Initilizes Phi functions for scaler arguments. Contains:
!   1. phi - initilizes phi functions using contour integral & recursion
!            relation.
! ===========================================================================

module phi_mod

    ! Module Parameters
    use pf_mod_dtype, only:  pfdp
    implicit none
    real(pfdp), parameter :: PI = 3.1415926535897932_pfdp
    complex(pfdp), parameter :: II = cmplx(0.0_pfdp,1.0_pfdp)

    ! Cauchy Integral Settings
    real(pfdp),   parameter :: c_tol = 1.0_pfdp         ! Smallest Lambda for contour integral
    real(pfdp),   parameter :: c_R   = 2.0_pfdp*c_tol   ! Contour Radius
    integer,      parameter :: c_M   = 32               ! Number of Points

    ! Interfaces For phi and phiw
    interface phi
        module procedure phi_zscalar, phi_zvector, phi_zmatrix, phi_rscalar, phi_rvector, phi_rmatrix
    end interface

    contains

    ! === FUNCTIONS FOR REAL-VALUED L ===========================

    subroutine phi_rvector(L, n, P)
        ! Arguments
        real(pfdp),  intent(in)  :: L(:)
        integer,     intent(in) :: n
        real(pfdp),  intent(out) :: P(n+1,size(L))
        ! Local Variables
        integer :: i, m
        complex(pfdp), allocatable :: LC(:)
        complex(pfdp), allocatable :: PC(:, :)
        m = size(L)
        allocate(LC(m))
        allocate(PC(n+1, m))
        do i = 1, m
            LC(i) = CMPLX(L(i), 0, pfdp)
        end do
        call phi_zvector(LC, n, PC)
        P = real(PC)
    end subroutine phi_rvector

    subroutine phi_rscalar(L, n, P)
        ! Arguments
        real(pfdp), intent(in)  :: L
        integer,    intent(in)  :: n
        real(pfdp), intent(out) :: P(n+1)
        ! Local Variables
        real(pfdp) :: PM(n+1, 1)
        real(pfdp) :: LV(1)
        ! Pack Arguments for call to phi_vector
        LV(1) = L
        call phi_rvector(LV, n, PM)
        ! Unpack Result
        P = PM(:,1)
    end subroutine phi_rscalar

    subroutine phi_rmatrix(L, n, P)
        ! Arguments
        real(pfdp), intent(in)  :: L(:,:)
        integer,       intent(in)  :: n
        real(pfdp), intent(out) :: P(n + 1, size(L, 1), size(L, 2))
        ! Local Variables
        integer       :: Ln, Lm, d
        real(pfdp), allocatable :: PM(:, :)
        real(pfdp), allocatable :: LV(:)
        ! Pack Arguments for call to phi_vector
        Lm = size(L, 1)
        Ln = size(L, 2)
        d  = Lm * Ln
        allocate(LV(d))
        allocate(PM(n+1, d))
        LV = reshape(L, (/ d /))
        call phi_rvector(LV, n, PM)
        ! Unpack Result
        P = reshape(PM, (/n+1, Ln, Lm/))
    end subroutine phi_rmatrix

    ! === FUNCTIONS FOR COMPLEX-VALUED L ===========================

    subroutine phi_zscalar(L, n, P)
        ! Arguments
        complex(pfdp), intent(in)  :: L
        integer,       intent(in)  :: n
        complex(pfdp), intent(out) :: P(n+1)
        ! Local Variables
        complex(pfdp) :: PM(n+1, 1)
        complex(pfdp) :: LV(1)
        ! Pack Arguments for call to phi_vector
        LV(1) = L
        call phi_zvector(LV, n, PM)
        ! Unpack Result
        P = PM(:,1)
    end subroutine phi_zscalar

    subroutine phi_zmatrix(L, n, P)
        ! Arguments
        complex(pfdp), intent(in)  :: L(:,:)
        integer,       intent(in)  :: n
        complex(pfdp), intent(out) :: P(n + 1, size(L, 1), size(L, 2))
        ! Local Variables
        integer       :: Ln, Lm, d
        complex(pfdp), allocatable :: PM(:, :)
        complex(pfdp), allocatable :: LV(:)
        ! Pack Arguments for call to phi_vector
        Lm = size(L, 1)
        Ln = size(L, 2)
        d  = Lm * Ln
        allocate(LV(d))
        allocate(PM(n+1, d))
        LV = reshape(L, (/ d /))
        call phi_zvector(LV, n, PM)
        ! Unpack Result
        P = reshape(PM, (/n+1, Ln, Lm/))
    end subroutine phi_zmatrix

    ! =======================================================================
    ! PHI   Evaluates \phi_i(L) for i=0,...,n and scaler/vector L using
    !       Recursion relation and Cauchy Integral Formula.
    !
    ! Arguments
    !
    !   L   (input) COMPLEX*16 array, dimensions(n)
    !       array of Lambda values cooresponding to PDE linear component
    !
    !   n   (input) INTEGER
    !       highest phi function to initialize.
    !
    !   P   (output) COMPLEX*16, dimensions(n,size(L))
    !       array where on exit P(i,j) = \phi_{i-1}(L(j))
    ! =======================================================================

    subroutine phi_zvector(L, n, P)
        ! Arguments
        complex(pfdp), intent(in)  :: L(:)
        integer,     intent(in)  :: n
        complex(pfdp), intent(out) :: P(n+1,size(L))
        ! Local Variables
        integer     :: i,j,k,nL
        real(pfdp)    :: f
        complex(pfdp) :: z(c_M)
        complex(pfdp) :: Li,Lzi,pp

        nL = size(L)
        P = 0;
        ! Set contour points
        do i=1,c_M
            z(i) = c_R * exp(2.0_pfdp*PI*II*(i-1.0_pfdp)/real(c_M,pfdp))
        enddo
        ! Compute Phi
        do i=1,nL
            Li = L(i)
            if(abs(Li) >= c_tol) then
                ! Direct Formula
                P(1,i) = exp(Li)
                f = 1.0_pfdp
                do j=2,n+1
                    P(j,i) = (P(j-1,i) - 1.0_pfdp/f)/Li
                    f = f*(j-1)
                enddo
            else
                ! Cauchy Integral Formula
                do k=1,c_M
                    Lzi = Li + z(k)
                    pp = exp(Lzi)
                    P(1,i) = P(1,i) + pp/c_M
                    f = 1.0_pfdp;
                    do j=2,n+1
                        pp = (pp - 1.0_pfdp/f)/Lzi
                        P(j,i) = P(j,i) + pp/c_M;
                        f = f*(j-1)
                    enddo
                enddo
                ! remove imaginary roundoff if L(i) is real
                if(aimag(Li) == 0.0_pfdp) then
                  P(:,i) = REAL(P(:,i))
                endif
            end if
        end do
end subroutine phi_zvector

end module phi_mod


PROGRAM  BARYCENTER
IMPLICIT NONE

!Data dictionary: dec1are constants
INTEGER::  N1    ! the number of voxels along axis x
INTEGER::  N2     ! the number of voxels along axis y
INTEGER::  N3     ! the number of voxels along axis z

! declare  variables
REAL(kind=8):: X0, Y0, Z0      ! the origin of the grid
REAL(kind=8):: X1, Y1, Z1      ! unit verctor in quasi x direction
REAL(kind=8):: X2, Y2, Z2      ! unit verctor in quasi y direction
REAL(kind=8):: X3, Y3, Z3      ! unit verctor in quasi z direction

CHARACTER(len=80):: in_filename    ! the name for the input cube file
CHARACTER(len=80):: out_filename    ! the name for output file

INTEGER:: i, j, k

REAL(kind=8), ALLOCATABLE, DIMENSION(:, :, :):: MO_COFF    ! the 3-D array to hold the MO coff values
REAL(kind=8), ALLOCATABLE, DIMENSION(:, :, :):: X_COORD     ! the 3-D array to hold the x coord of all points
REAL(kind=8), ALLOCATABLE, DIMENSION(:, :, :):: Y_COORD     ! the 3-D array to hold the y coord of all points
REAL(kind=8), ALLOCATABLE, DIMENSION(:, :, :):: Z_COORD     ! the 3-D array to hold the z coord of all points

INTEGER:: status
INTEGER:: I1, I2, I3

REAL(kind=8):: X_AVE, Y_AVE, Z_AVE
REAL(kind=8):: X_MO_SUM2, Y_MO_SUM2, Z_MO_SUM2
REAL(kind=8):: MO_SUM2
REAL(kind=8):: temp

REAL:: start, finish
CALL cpu_time(start)

!**************************main program*************************
!***************************************************************
!--- prompt user to enter the N1, N2, N3 points for x, y, z axies
WRITE(*,'(1X, A)') "Enter the number of voxels along axis x, y and z axies,"
WRITE(*,'(1X, A)') "N1, N2, N3 ="
READ(*, *) N1, N2, N3

WRITE(*,'(1X, A)') "Enter the origin point, and unit vector"
WRITE(*,'(1X, A)') "X0, Y0, Z0 ="
WRITE(*,'(1X, A)') "X1, Y1, Z1 ="
WRITE(*,'(1X, A)') "X2, Y2, Z2 ="
WRITE(*,'(1X, A)') "X3, Y3, Z3 ="
READ(*, *) X0, Y0, Z0
READ(*, *) X1, Y1, Z1
READ(*, *) X2, Y2, Z2
READ(*, *) X3, Y3, Z3

! print the input parameters to user
WRITE(*,'(1X, A)') "The input parameters for "
WRITE(*,'(1X, A)') "N1, N2, N3 ="
WRITE(*,'(1X, A)') "X0, Y0, Z0 ="
WRITE(*,'(1X, A)') "X1, Y1, Z1 ="
WRITE(*,'(1X, A)') "X2, Y2, Z2 ="
WRITE(*,'(1X, A)') "X3, Y3, Z3 ="
WRITE(*,'(1X, 3I8)')  N1, N2, N3
WRITE(*,'(1X, 3E13.5)') X0, Y0, Z0
WRITE(*,'(1X, 3E13.5)') X1, Y1, Z1
WRITE(*,'(1X, 3E13.5)') X2, Y2, Z2
WRITE(*,'(1X, 3E13.5)') X3, Y3, Z3

!------Allocate arrays------------------------
ALLOCATE ( MO_COFF(N3, N2, N1) , STAT=status)
IF (status /= 0 ) THEN
   STOP "Allocate MO_COFF failed!"
END IF

ALLOCATE ( X_COORD(N3, N2, N1) , STAT=status)
IF (status /= 0 ) THEN
   STOP "Allocate X_COORD failed!"
END IF

ALLOCATE ( Y_COORD(N3, N2, N1) , STAT=status)
IF (status /= 0 ) THEN
   STOP "Allocate Y_COORD failed!"
END IF

ALLOCATE ( Z_COORD(N3, N2, N1) , STAT=status)
IF (status /= 0 ) THEN
   STOP "Allocate Z_COORD failed!"
END IF

!X0= -16.521180; Y0= -12.758327;  Z0= -10.871973
!X1 = 0.356422 ; Y1=  0.000000;  Z1 =   0.000000
!X2=  0.000000; Y2= 0.356422 ; Z2=   0.000000
!X3=  0.000000; Y3=   0.000000; Z3 = 0.356422

MO_SUM2=0.
X_MO_SUM2=0.
Y_MO_SUM2=0.
Z_MO_SUM2=0.
X_AVE=0.
Y_AVE=0.
Z_AVE=0.

!-- initialize array elements to 0.
Do I1=1, N1
      Do  I2=1, N2
         Do  I3=1, N3
            MO_COFF(I3,I2,I1)= 0.
            X_COORD(I3,I2,I1)= 0.
            Y_COORD(I3,I2,I1)= 0.
            Z_COORD(I3,I2,I1)= 0.
         END DO
      END DO
END DO

!----------------------------------------------------------------
WRITE (*, 1000 )
1000 FORMAT (' Enter the file name containing the input data: ')
READ (*,' (A80) ') in_filename

!Open input data file. Status is OLD because the input data must
!a1ready exist.
OPEN ( UNIT=10 , FILE=in_filename , STATUS='OLD' , ACTION='READ' , &
IOSTAT=status )
!Was the OPEN successfu1?
fileopen: IF (status == 0) THEN
!The file was opened successfu11y, so read the data to process.
! read in data for array MO_COFF
Do I1=1, N1
      Do  I2=1, N2
         Read(10,'(6E13.5)', IOSTAT=status) ( MO_COFF(I3,I2,I1), I3=1,N3 )
      END DO
END DO

ELSE  fileopen
!E1se file open fai1ed. Te11 user.
WRITE (*, 1030) status
1030 FORMAT (1X , 'file open failed--status ', I6)
END IF fileopen

CLOSE(UNIT=10)

!-- calculate the x, y, z coordinates for all grid points
! stored in three respective arrays
Do I1=1, N1
      Do  I2=1, N2
         Do  I3=1, N3
            X_COORD(I3,I2,I1)= X0+(I1-1)*X1+(I2-1)*X2+(I3-1)*X3
            Y_COORD(I3,I2,I1)= Y0+(I1-1)*Y1+(I2-1)*Y2+(I3-1)*Y3
            Z_COORD(I3,I2,I1)= Z0+(I1-1)*Z1+(I2-1)*Z2+(I3-1)*Z3
         END DO
      END DO
END DO

!---------------- Calculated the average values for X,Y,Z weighted by
!---------------- the MO cofficients.
!#################################################################

Do I1=1, N1
      Do  I2=1, N2
         Do  I3=1, N3
            MO_SUM2= MO_SUM2 + MO_COFF(I3,I2,I1)*MO_COFF(I3,I2,I1)
         END DO
      END DO
END DO
!MO_SUM2= SUM(MO_COFF)

Do I1=1, N1
      Do  I2=1, N2
         Do  I3=1, N3
            X_MO_SUM2= X_MO_SUM2 + X_COORD(I3,I2,I1)*MO_COFF(I3,I2,I1)*MO_COFF(I3,I2,I1)
            Y_MO_SUM2= Y_MO_SUM2 + Y_COORD(I3,I2,I1)*MO_COFF(I3,I2,I1)*MO_COFF(I3,I2,I1)
            Z_MO_SUM2= Z_MO_SUM2 + Z_COORD(I3,I2,I1)*MO_COFF(I3,I2,I1)*MO_COFF(I3,I2,I1)
         END DO
      END DO
END DO

X_AVE= X_MO_SUM2/MO_SUM2
Y_AVE= Y_MO_SUM2/MO_SUM2
Z_AVE= Z_MO_SUM2/MO_SUM2

!#################################################################

!-------------------------------------------------------------------
!Te11 user. For purpose of check
!WRITE(*, '(1X,A)') "#--------------------------------------------"
!WRITE(*, '(1X,A)') "# MO_COFF is:"
!
!Do I1=1, N1
!      Do  I2=1, N2
!         WRITE(*,'(6E13.5)') ( MO_COFF(I3,I2,I1), I3=1,N3 )
!      END DO
!END DO
!
!WRITE(*, '(1X,A)') "#--------------------------------------------"
!WRITE(*, '(1X,A)') "# X_COORD is:"
!
!Do I1=1, N1
!      Do  I2=1, N2
!         WRITE(*,'(6E13.5)') ( X_COORD(I3,I2,I1), I3=1,N3 )
!      END DO
!END DO
!
!WRITE(*,'(1X,A)') "#--------------------------------------------"
!WRITE(*,'(1X,A)') "# Y_COORD is:"
!
!Do I1=1, N1
!      Do  I2=1, N2
!         WRITE(*,'(6E13.5)') ( Y_COORD(I3,I2,I1), I3=1,N3 )
!      END DO
!END DO
!
!WRITE(*,'(1X,A)') "#--------------------------------------------"
!WRITE(*,'(1X,A)') "# Z_COORD is:"
!
!Do I1=1, N1
!      Do  I2=1, N2
!         WRITE(*,'(6E13.5)') ( Z_COORD(I3,I2,I1), I3=1,N3 )
!      END DO
!END DO

WRITE(*,'(1X,A)') "---------------------------------------------------------"
WRITE(*,'(1X,A)') "############### FINAL SUMMARY OF BARYCENTER #############"
WRITE(*,'(1X,A)') "#--------------------------------------------------------"
WRITE(*,'(1X, A)') "The input parameters for "
WRITE(*,'(1X, A20, 3I8)')  "N1, N2, N3 = ",  N1, N2, N3
WRITE(*,'(1X, A20, 3E13.5)') "X0, Y0, Z0 =", X0, Y0, Z0
WRITE(*,'(1X, A20, 3E13.5)') "X1, Y1, Z1 =", X1, Y1, Z1
WRITE(*,'(1X, A20, 3E13.5)') "X2, Y2, Z2 =", X2, Y2, Z2
WRITE(*,'(1X, A20, 3E13.5)') "X3, Y3, Z3 =", X3, Y3, Z3
WRITE(*,'(1X, A)' ) ""
WRITE(*,'(1X,A20, E13.5)') "# MO_SUM2    = ", MO_SUM2
WRITE(*,'(1X,A20, E13.5)') "# X_MO_SUM2  = ", X_MO_SUM2
WRITE(*,'(1X,A20, E13.5)') "# Y_MO_SUM2  = ", Y_MO_SUM2
WRITE(*,'(1X,A20, E13.5)') "# Z_MO_SUM2  = ", Z_MO_SUM2
WRITE(*,'(1X,A, E13.5)') "# MO_SUM2 * X1 * Y2 * Z3 = ", MO_SUM2*X1*Y2*Z3
WRITE(*,'(1X,A20, E13.5)') "# X_AVE     = ", X_AVE
WRITE(*,'(1X,A20, E13.5)') "# Y_AVE     = ", Y_AVE
WRITE(*,'(1X,A20, E13.5)') "# Z_AVE     = ", Z_AVE

!-----Deallocate arrays-------------------------
DEALLOCATE ( MO_COFF, STAT=status )
DEALLOCATE ( X_COORD, STAT=status )
DEALLOCATE ( Y_COORD, STAT=status )
DEALLOCATE ( Z_COORD, STAT=status )

! put code to test here
CALL cpu_time(finish)

WRITE (*, '(1X,A)') "#-----------------------------------------------"
WRITE (*, 2000)  finish - start
2000  FORMAT (1X, 'Time = ', f6.3," seconds.")

STOP
END PROGRAM  BARYCENTER


program test
  integer, parameter :: k = 8
  real (kind = k), parameter :: pi = 3.142
  print *, pi
end program test


MODULE point_module
IMPLICIT NONE

! Type definition
TYPE :: point
   REAL :: x
   REAL :: y
CONTAINS
   PROCEDURE,PASS :: add
END TYPE

CONTAINS

   TYPE(point) FUNCTION add(this, another_point)
   CLASS(point) :: this, another_point
   add%x = this%x + another_point%x
   add%y = this%y + another_point%y
   END FUNCTION add

END MODULE point_module

PROGRAM test_bound_procedures
!
!  Purpose:
!    To test bound procedurres.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     12/04/06    S. J. Chapman        Original code
!
USE point_module
IMPLICIT NONE

! Declare a variable of type point
TYPE (point) :: a, b, c

! Initialize variables
a%x = -10.
a%y = 5.
b%x = 4.
b%y = 2.

! Add points
c = a%add(b)

! Output variable using free format I/O
WRITE (*,*) 'c = ', c

END PROGRAM test_bound_procedures


!>
!! \brief This module contains astronomical constants and units
!!
!! Module for Capreole / C2-Ray (f90)
!!
!! \b Author: Garrelt Mellema
!!
!! \b Date: 2003-06-01
!!
!! \b Version: cgs units
!!
!! This module is also accepted by the F compiler (Dec 9, 2003)

module astroconstants

  use precision, only: dp

  implicit none

  ! A collection of astronomical units and conversion factors
  ! Units: cgs

  real(kind=dp),parameter :: R_SOLAR=6.9599e10 !< Solar radius
  real(kind=dp),parameter :: L_SOLAR=3.826e33 !< Solar luminosity
  real(kind=dp),parameter :: M_SOLAR=1.98892d33 !< Solar mass

  real(kind=dp),parameter :: YEAR=3.15576E+07 !< Julian year

  real(kind=dp),parameter :: pc=3.086e18 !< parsec
  real(kind=dp),parameter :: kpc=1e3*pc !< kiloparsec
  real(kind=dp),parameter :: Mpc=1e6*pc !< megaparsec
  real(kind=dp),parameter :: lightyear=9.463e17 !< lightyear
  real(kind=dp),parameter :: AU=1.49597870E+13 !< Astronomical Unit

end module astroconstants


MODULE environ

	use constantes
	implicit none

	contains

subroutine magneticf(V,B)
	!----------------------------------------------------------
	! Magnetic field computation.
	! CALLING SEQUENCE: call magneticf(V,B)
	! INPUTS:  V: position vector in cartesian coordinates
	! OUTPUTS: B: magnetic field vector in cartesian coordinate (Tesla)
	!----------------------------------------------------------
	real(kind=8), dimension(:,:),intent(in)  :: V
	real(kind=8), dimension(:,:),intent(out) :: B

	B(1,:)=0.
	B(2,:)=0.
	B(3,:)=B0*(V(3,:)/z0B)**(-3)

end subroutine magneticf

subroutine read_environ()
        !----------------------------------------------------
        ! Lit le fichier init_environ.txt et range les donnees
        !  dans un fichier
        !----------------------------------------------------
        use constantes

        open(40,file='init_environ.txt')
        read(40,*)n0
        read(40,*)z0
        read(40,*)B0
        read(40,*)z0B
        close(40)
        write (*,*)"n0 ",n0," z0 ",z0," B0 ",B0," z0B ",z0B

end subroutine read_environ

subroutine density(V,Ne)
	!-----------------------------------------------------
	! Electron density computation
	! CALLING SEQUENCE: call density(V,Ne)
	! INPUTS:   V: position vector in cartesian coordinates
	! OUTPUTS: Ne: electron density (cm-3)
	!-----------------------------------------------------
        use constantes
        real(kind=8),dimension(:,:),intent(in)    :: V
	real(kind=8), dimension(:), intent(out)   :: Ne

!	real(kind=8)                              :: n0,z0

!	open(40, file='init_environ.txt')
!	read(40,*) n0
!	read(40,*) z0

	Ne(:)=n0*(V(3,:)/z0)**(-2)

!	close(40)

end subroutine density

END MODULE environ


      SUBROUTINE TestWout(rzl_array, br, bz, bsupu, bsupv)
      USE stel_kinds, ONLY: rprec, dp
      USE stel_constants, ONLY: twopi
      USE read_wout_mod, ONLY: read_wout_file, read_wout_deallocate,
     1                         tosuvspace
      USE vmec_params, ONLY: mscale, nscale, ntmax
      USE vmec_dim, ONLY: ns, ntheta3, ntheta1, nrzt
      USE vmec_input, ONLY: mpol, nzeta, ntor, lasym, nfp
      USE vmec_main, ONLY: hs, lthreed
      USE realspace, ONLY: r1, z1, shalf, sqrts
      USE vforces
      USE vmec_utils, ONLY: getbcyl
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec), INTENT(in)  ::
     1             rzl_array(ns,0:ntor,0:mpol,2*ntmax)
      REAL(rprec), DIMENSION(ns,nzeta,ntheta3), INTENT(in)
     1                         :: bsupu, bsupv
      REAL(rprec), DIMENSION(nrzt), INTENT(in) :: br, bz
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: j, js, k, l, istat
      REAL(rprec) :: si, ui, vi, r12, z12,
     1               sflx, uflx, rfull, zfull
      REAL(rprec) :: br12, bz12, bphi12,
     1               br1f, bz1f, bphi1f, br2f, bz2f, bphi2f
      LOGICAL :: ls_mesh = .false.               !=T, full mesh, =F, half mesh
C-----------------------------------------------
!      CALL read_wout_file("tichman", istat)
      CALL read_wout_file("bean14", istat)
      IF (istat .ne. 0) RETURN

!      gsqrt => azmn_o    !gsqrt
!      r12 => armn_o; bphi => czmn_o
!      bsupu => crmn_e
!      bsupv => czmn_e

      js = 3*ns/4
!      js = 2                   !!Check this: not working as well as it should at js=2, js>=3 is EXCELLENT!!!
      si = hs*(js-1.5_dp)

      IF (ls_mesh) THEN
        WRITE(33,'(3a)')
     1  '   L  sflx-del  uflx-del      br1/2     bphi1/2       bz1/2',
     2  '     brf-wout  bphif-wout    bzf-wout    brf-vmec  bphif-vmec',
     3  '    bzf-vmec'
      END IF

      DO k = 1, nzeta
         vi = (twopi*(k-1))/nzeta
         DO j = 1, ntheta3
            ui = (twopi*(j-1))/ntheta1
            l = js + ns*(k-1 + nzeta*(j-1))

            IF (ls_mesh) THEN

               rfull = r1(l,0) + sqrts(l)*r1(l,1)
               zfull = z1(l,0) + sqrts(l)*z1(l,1)
!
!          TEST WOUT-BASED VERSION
!
               CALL GetBcyl(rfull, vi/nfp, zfull, br1f, bphi1f, bz1f,
     1                      sflx, uflx, istat)
               IF (istat .ne. 0) PRINT *,' WOUT-BASED ISTAT = ', istat
!
!          TEST VMEC-BASED VERSION
!
               CALL GetBcyl(rfull, vi/nfp, zfull, br2f, bphi2f, bz2f,
     1           sflx, uflx, bsupu, bsupv, rzl_array, ns, ntor, mpol,
     2           ntmax, nzeta, ntheta3, nfp, mscale, nscale,
     3           lthreed, lasym, istat)
               IF (istat .ne. 0) PRINT *,' VMEC-BASED ISTAT = ', istat

               WRITE (33, 1225) l, sflx-si, MOD(uflx-ui,twopi),
     1            br(l), czmn_o(l), bz(l),
     2            br1f, bphi1f, bz1f, br2f, bphi2f, bz1f

 1225   FORMAT(i4, 1p,2e10.2, 9e12.3)

            ELSE

            z12 = (z1(l,0) + z1(l-1,0) + shalf(l)*
     1            (z1(l,1) + z1(l-1,1)))/2
            r12 = armn_o(l)

!
!           TEST WOUT-BASED VERSION
!
            CALL GetBcyl(r12, vi/nfp, z12, br12, bphi12, bz12,
     1                   sflx, uflx, istat)

            IF (istat .eq. 0) THEN
               WRITE (33, 1224) l, sflx-si, MOD(uflx-ui,twopi),
     1            (br(l) - br12)/bphi12, (czmn_o(l)-bphi12)/bphi12,
     2            (bz(l) - bz12)/bphi12
            ELSE
               WRITE (33, *)' istat = ', istat
            END IF

!
!          TEST VMEC-BASED VERSION (OVERLOADED, SAME FUNCTION CALL, DIFF ARG.)
!
            CALL GetBcyl(r12, vi/nfp, z12, br12, bphi12, bz12, sflx,
     1           uflx, bsupu, bsupv, rzl_array, ns, ntor, mpol,
     2           ntmax, nzeta, ntheta3, nfp, mscale, nscale,
     3           lthreed, lasym, istat)
            IF (istat .eq. 0) THEN
               WRITE (34, 1224) l, sflx-si, MOD(uflx-ui,twopi),
     1            (br(l) - br12)/bphi12, (czmn_o(l)-bphi12)/bphi12,
     2            (bz(l) - bz12)/bphi12
            ELSE
               WRITE (34, *)' istat = ', istat
            END IF

            END IF

!            CALL tosuvspace(si,ui,vi,gsqrt=gsqrt1)
!            WRITE(33, 1223) l, gsqrt(l), gsqrt1,
!     1                 ABS(gsqrt(l)-gsqrt1)/ABS(gsqrt1)
         END DO
      END DO
 1223 FORMAT(' l = ',i4,' GSQRT = ',1p,e12.4,' FROM WOUT = ',e12.4,
     1      ' REL.ERROR = ',e10.2)
 1224 FORMAT(' l = ',i4, ' del-SFLX = ', 1p,e10.2,
     1                   ' del-UFLX = ', e10.2,
     2                   ' del-BR = ', e12.4,' del-BPHI = ',
     3            e12.4, ' del-BZ = ', e12.4)

      CALL read_wout_deallocate

      END SUBROUTINE TestWout


      subroutine h4qn(p1,p2,p3,p4,ampsq)
      implicit none
C     Taken from Kauffman,Desai,Risal
C     PRD 55 1997 (4009)
c     q(-p1)+qp(-p2)--> h --> q(p3)+qp(p4)
C     returns overall matrix element squared
C     summed over colors and spins with factor of g^4*A^2 removed
      include 'constants.f'
      include 'sprods_com.f'
      double precision ampsq,ammsq
      integer p1,p2,p3,p4
c      include 'zprods_com.f'
c      integer j1,j2
c      double complex a(2,2),b(2,2),amm
C  Eq 29 (suitably modified for my momentum configuration)
C====statement function
C--left-left amplitude
c      amm(p1,p2,p3,p4)=
c     . +za(p3,p4)**2/(za(p1,p3)*za(p2,p4))
c     . +zb(p1,p2)**2/(zb(p1,p3)*zb(p2,p4))
C--The above amplitude squared + color factor
      ammsq(p1,p2,p3,p4)=V/4d0
     . *((s(p1,p2)-s(p3,p4))**2+
     . (s(p1,p3)*s(p2,p4)+s(p3,p4)*s(p1,p2)-s(p1,p4)*s(p2,p3))**2
     .  /(s(p1,p3)*s(p2,p4)))/(s(p1,p3)*s(p2,p4))
      ampsq=ammsq(p1,p2,p3,p4)+ammsq(p3,p2,p1,p4)
     .     +ammsq(p1,p4,p3,p2)+ammsq(p3,p4,p1,p2)

      return
      end

      subroutine h4qi(p1,p2,p3,p4,ampsqid,ampsq_a,ampsq_b,ampsq_i)
      implicit none
C     Taken from Kauffman,Desai,Risal
C     PRD 55 1997 (4009)
c     q(-p1)+qp(-p2)--> h --> q(p3)+qp(p4)
C     returns overall matrix element squared
C     summed over colors and spins with factor of g^4*A^2 removed
      include 'constants.f'
      include 'sprods_com.f'
      double precision ampsqid,ammsq,ammsqi,ampsq_a,ampsq_b,ampsq_i
      integer p1,p2,p3,p4
c      include 'zprods_com.f'
c      integer j1,j2
c      double complex a(2,2),b(2,2),amm
C  Eq 29 (suitably modified for my momentum configuration)
C====statement function
C--left-left amplitude
c      amm(p1,p2,p3,p4)=
c     . +za(p3,p4)**2/(za(p1,p3)*za(p2,p4))
c     . +zb(p1,p2)**2/(zb(p1,p3)*zb(p2,p4))
C--The above amplitude squared + color factor
      ammsq(p1,p2,p3,p4)=V/4d0
     . *((s(p1,p2)-s(p3,p4))**2+
     . (s(p1,p3)*s(p2,p4)+s(p3,p4)*s(p1,p2)-s(p1,p4)*s(p2,p3))**2
     .  /(s(p1,p3)*s(p2,p4)))/(s(p1,p3)*s(p2,p4))
C--The interference with color factor Eq.(A20)
C-- Note: sign of this term changed by JMC on 8/8/05 to agree with
c-- the other routine in Hqaqasq.f; one minus sign comes from the
c-- colour factor, the other from a single fermion loop
      ammsqi(p1,p2,p3,p4)=+cf/2d0
     . *((s(p1,p2)-s(p3,p4))**2
     . *(s(p1,p3)*s(p2,p4)+s(p1,p4)*s(p2,p3)-s(p1,p2)*s(p3,p4))
     . -2d0*(s(p1,p2)*s(p3,p4)+s(p2,p3)*s(p1,p4)-s(p1,p3)*s(p2,p4))
     .     *(s(p3,p4)*s(p1,p2)+s(p1,p3)*s(p2,p4)-s(p1,p4)*s(p2,p3))
     .  )/(s(p1,p3)*s(p2,p3)*s(p1,p4)*s(p2,p4))

c--- calculate the matrix element as the sum of two pieces,
c--- related by the interchange of p3 and p4, plus an interference
c--- term that is colour-suppressed

      ampsq_a=ammsq(p1,p2,p3,p4)+ammsq(p3,p2,p1,p4)
     .       +ammsq(p1,p4,p3,p2)+ammsq(p3,p4,p1,p2)
      ampsq_b=ammsq(p1,p2,p4,p3)+ammsq(p4,p2,p1,p3)
     .       +ammsq(p1,p3,p4,p2)+ammsq(p4,p3,p1,p2)
      ampsq_i=ammsqi(p1,p2,p3,p4)+ammsqi(p3,p4,p1,p2)

      ampsqid=ampsq_a+ampsq_b+ampsq_i

      return
      end


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                mnparc : parcur test program                        cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(64),w(32),u(32),t(40),c(80),wrk(1200),sp(64)
      integer iwrk(40)
      real al,del,fp,s,ub,ue
      integer i,idim,ier,iopt,ipar,is,i1,i2,j,j1,k,l,lwrk,l1,m,mx,
     * n,nc,nest,nk1
c  the data parameter values
      data u(1),u(2),u(3),u(4),u(5),u(6),u(7),u(8),u(9),u(10),u(11),
     * u(12),u(13),u(14),u(15),u(16),u(17),u(18),u(19),u(20),u(21),
     * u(22),u(23),u(24),u(25),u(26),u(27),u(28),u(29),u(30),u(31),
     * u(32)/120.,128.,133.,136.,138.,141.,144.,146.,149.,151.,154.,
     * 161.,170.,180.,190.,200.,210.,220.,230.,240.,250.,262.,269.,
     * 273.,278.,282.,287.,291.,295.,299.,305.,315./
c  the data absciss values
      data x(1),x(3),x(5),x(7),x(9),x(11),x(13),x(15),x(17),x(19),x(21),
     * x(23),x(25),x(27),x(29),x(31),x(33),x(35),x(37),x(39),x(41),
     * x(43),x(45),x(47),x(49),x(51),x(53),x(55),x(57),x(59),x(61),
     * x(63)/-1.5141,-2.0906,-1.9253,-0.8724,-0.3074,-0.5534,0.0192,
     * 1.2298,2.5479,2.4710,1.7063,1.1183,0.5534,0.4727,0.3574,0.1998,
     * 0.2882,0.2613,0.2652,0.2805,0.4112,0.9377,1.3527,1.5564,1.6141,
     * 1.6333,1.1567,0.8109,0.2498,-0.2306,-0.7571,-1.1222/
c  the data ordinate values
      data x(2),x(4),x(6),x(8),x(10),x(12),x(14),x(16),x(18),x(20),
     * x(22),x(24),x(26),x(28),x(30),x(32),x(34),x(36),x(38),x(40),
     * x(42),x(44),x(46),x(48),x(50),x(52),x(54),x(56),x(58),x(60),
     * x(62),x(64)/0.5150,1.3412,2.6094,3.2358,2.7401,2.7823,3.5932,
     * 3.8353,2.5863,1.3105,0.6841,0.2575,0.2460,0.3689,0.2460,0.2998,
     * 0.3651,0.3343,0.3881,0.4573,0.5918,0.7110,0.4035,0.0769,-0.3920,
     * -0.8570,-1.3412,-1.5641,-1.7409,-1.7178,-1.2989,-0.5572/
c  m denotes the number of data points
      m = 32
c  we set up the weights of the data points
      do 10 i=1,m
         w(i) = 1.0
  10  continue
c  we set up the dimension information.
      nest = 40
      lwrk = 1200
      nc = 80
      mx = 64
c  we will determine a planar curve   x=sx(u) , y=sy(u)
      idim = 2
c  for the first approximations we will use cubic splines
      k = 3
c  we will also supply the parameter values u(i)
      ipar = 1
      ub = 120.
      ue = 320.
c  loop for the different approximating spline curves
      do 400 is=1,9
         go to (110,120,130,140,150,160,170,180,190),is
c  we start computing a polynomial curve ( s very large)
 110     iopt = 0
         s = 100.
         go to 300
c  iopt =  1 from the second call on
 120     iopt = 1
         s = 1.0
         go to 300
c  a smaller value for s to get a closer approximation
 130     s = 0.05
         go to 300
c  a larger value for s to get a smoother approximation
 140     s = 0.25
         go to 300
c  if a satisfactory fit is obtained we can calculate a curve of equal
c  quality of fit (same value for s) but possibly with fewer knots by
c  specifying iopt=0
 150     iopt = 0
         s = 0.25
         go to 300
c  we determine a spline curve with respect to the same smoothing
c  factor s,  but now we let the program determine parameter values u(i)
 160     ipar = 0
         iopt = 0
         s = 0.25
         go to 300
c  we choose a different degree of spline approximation
 170     k = 5
         iopt = 0
         s = 0.25
         go to 300
c  we determine an interpolating curve
 180     s = 0.
         go to 300
c  finally we calculate a least-squares spline curve with specified
c  knots
 190     iopt =-1
         n = 9+2*k
         j = k+2
         del = (ue-ub)*0.125
         do 200 l=1,7
            al = l
            t(j) = ub+al*del
            j = j+1
 200     continue
c  determine the approximating curve
 300     call parcur(iopt,ipar,idim,m,u,mx,x,w,ub,ue,k,s,nest,n,t,
     *    nc,c,fp,wrk,lwrk,iwrk,ier)
c  printing of the results.
         if(iopt.ge.0) go to 310
         write(6,910) k,ipar
         go to 320
 310     write(6,915) k,ipar
         write(6,920) s
 320     write(6,925) fp,ier
         write(6,930) n
         write(6,935)
         if(ipar.eq.1) write(6,940) (t(i),i=1,n)
         if(ipar.eq.0) write(6,950) (t(i),i=1,n)
         nk1 = n-k-1
         write(6,945)
         write(6,950) (c(l),l=1,nk1)
         write(6,955)
         i1 = n+1
         i2 = n+nk1
         write(6,950) (c(l),l=i1,i2)
         write(6,960)
c  we evaluate the spline curve
         call curev(idim,t,n,c,nc,k,u,m,sp,mx,ier)
         do 330 i=1,8
           l = (i-1)*8+3
           l1 = l+1
           j = l+4
           j1 = j+1
           write(6,965) x(l),x(l1),sp(l),sp(l1),x(j),x(j1),sp(j),sp(j1)
 330     continue
 400  continue
      stop
 910  format(31h0least-squares curve of degree ,i1,7h  ipar=,i1)
 915  format(27h0smoothing curve of degree ,i1,7h  ipar=,i1)
 920  format(20h smoothing factor s=,f7.2)
 925  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i2)
 930  format(1x,24htotal number of knots n=,i3)
 935  format(1x,22hposition of the knots )
 940  format(5x,10f6.0)
 945  format(1x,30hb-spline coefficients of sx(u))
 950  format(5x,8f8.4)
 955  format(1x,30hb-spline coefficients of sy(u))
 960  format(1h0,2(4x,2hxi,7x,2hyi,6x,6hsx(ui),3x,6hsy(ui)))
 965  format(1h ,8f9.4)
      end


	SUBROUTINE GSGGRF  ( ixtyp, iytyp, kx, ky, xll, yll, xur, yur,
     +			     iret )
C************************************************************************
C* GSGGRF								*
C* 									*
C* This subroutine defines the coordinate system for a grid which is	*
C* evenly spaced in a graph coordinate system.  If the grid is defined	*
C* in a polar coordinates system, the grid rows correspond to constant	*
C* THETA values; the grid columns correspond to constant values of R.	*
C* XLL, YLL, XUR and YUR correspond to the min R, min THETA, max R and	*
C* max THETA.  XLL must be greater than or equal to 0.			*
C*									*
C* GSGGRF  ( IXTYP, IYTYP, KX, KY, XLL, YLL, XUR, YUR, IRET )		*
C* 							        	*
C* Input parameters:					        	*
C*	IXTYP		INTEGER		X coordinate type 		*
C*					  1 = linear			*
C*					  2 = logarithmic		*
C*					  3 = ** KAPPA (2/7)		*
C*					  5 = polar (R)			*
C*	IYTYP		INTEGER		Y coordinate type		*
C*					  1 = linear			*
C*					  2 = logarithmic		*
C*					  3 = ** KAPPA (2/7)		*
C*					  5 = polar (THETA)		*
C*	KX		INTEGER		Number of x grid points		*
C*	KY		INTEGER		Number of y grid points		*
C*	XLL 		REAL		Lower left x value		*
C*	YLL		REAL		Lower left y value		*
C*	XUR		REAL		Upper right x value		*
C*	YUR		REAL		Upper right y value		*
C*									*
C* Output parameters:							*
C* 	IRET 		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins	10/85	GEMPLT Version 3.1			*
C* M. desJardins	 6/86	Eliminated skew-t coordinates		*
C* M. desJardins	10/86	Modified to add polar coordinates	*
C* M. desJardins	 1/87	Corrected error in polar coordinates	*
C* M. desJardins/GSFC	 6/88	Changed calling sequence to have kx,ky	*
C************************************************************************
	INCLUDE 	'ERROR.PRM'
	INCLUDE		'XYDEF.CMN'
C------------------------------------------------------------------------
C*	Check for graph mode.
C
	ggset = .false.
	IF  ( igmode .ne. 2 )  THEN
	    iret = NIMODE
C
C*	  Check for invalid types.
C
	  ELSE IF  ( ( ( ixtyp .lt. 1 ) .or. ( ixtyp .gt. 3 ) .or.
     +		       ( iytyp .lt. 1 ) .or. ( iytyp .gt. 3 ) ) .and.
     +		     ( ( ixtyp .ne. 5 ) .or. ( iytyp .ne. 5 ) ) )  THEN
	    iret = NINVAL
C
C*	  Check for invalid values for logarithmic types.
C
	  ELSE IF  ( ( ( ixtyp .eq. 2 ) .and.
     +		     ( (   xll .le. 0. ) .or. ( xur .le. 0. ) ) ) .or.
     +		     ( ( iytyp .eq. 2 ) .and.
     +		     ( (   yll .le. 0. ) .or. ( yur .le. 0. ) ) ) ) THEN
	    iret = NINVAL
C
C*	  Check for invalid range or scale factor.
C
	  ELSE IF  ( ( xll .eq. xur ) .or. ( yll .eq. yur ) )  THEN
	    iret = NINVAL
C
C*	  Check for invalid polar coordinate types.
C
	  ELSE IF ((( ixtyp .eq. 5 ) .and. ( iytyp .eq. 5 )).and.
     +		   (( xll .ge. xur ) .or. ( yll .ge. yur ) .or.
     +		    ( xll .lt. 0. ))) THEN
C
	    iret = NINVAL
C
C*	  Save parameters.
C
	  ELSE
	    iret    = NORMAL
	    jgxtyp  = ixtyp
	    jgytyp  = iytyp
	    gpxl    = 1.
	    gpyb    = 1.
	    gpxr    = FLOAT ( kx )
	    gpyt    = FLOAT ( ky )
	    gxlmg   = xll
	    gybmg   = yll
	    gxrmg   = xur
	    gytmg   = yur
	    ggset   = .true.
C
C*	    Update values in grid common area.
C
	    CALL UPDGDG  ( ier )
	END IF
C*
	RETURN
	END


!########################################################
!     Program  : HMIPT
!     TYPE     : Main program
!     PURPOSE  : Solve the Hubbard model using DMFT-IPT
!     AUTHORS  : Adriano Amaricci
!########################################################
program hmipt_matsuara_2dsquare
  USE DMFT_IPT
  USE SQUARE_LATTICE
  USE IOTOOLS
  USE ERROR
  implicit none

  logical                :: converged
  real(8)                :: n,z,epot,doble
  integer                :: i,Lk,iloop
  complex(8)             :: zeta
  complex(8),allocatable :: fg(:),fg0(:),sigma(:)
  real(8),allocatable    :: wm(:),wt(:),epsik(:),nk(:),sigma_tau(:),SxG(:),fg_tau(:)

  call read_input("inputIPT.in")
  !allocate functions:
  allocate(fg(L),sigma(L),fg0(L))

  !build freq. array
  allocate(wm(L))
  wm(:)  = pi/beta*real(2*arange(1,L)-1,8)

  !build square lattice structure:
  Lk   = square_lattice_dimension(Nx,Nx)
  allocate(wt(Lk),epsik(Lk),nk(Lk))
  wt   = square_lattice_structure(Lk,Nx,Nx)
  epsik= square_lattice_dispersion_array(Lk,ts)

  !get or read first sigma
  call  get_inital_sigma(Sigma,"Sigma.restart")

  !dmft loop:
  iloop=0 ; converged=.false.
  do while (.not.converged.AND.iloop<nloop)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop
     !SELF-CONSISTENCY:
     do i=1,L
        zeta = xi*wm(i) - sigma(i)
        fg(i) = sum_overk_zeta(zeta,epsik,wt)
     enddo
     n   = get_local_density(fg,beta)
     fg0 = one/(one/fg + sigma)
     !
     !IMPURITY SOLVER
     sigma=solve_ipt_matsubara(fg0)
     sigma=xi*dimag(sigma)
     converged=check_convergence(fg0,dmft_error,nsuccess,nloop)
     !GET OBSERVABLES
     z=1.d0 - dimag(sigma(1))/wm(1);z=1.d0/z
     call splot("observables_all.ipt",dble(iloop),u,beta,n,z,append=.true.)
  enddo
  call splot("G_iw.ipt",wm,fg)
  call splot("G0_iw.ipt",wm,fg0)
  call splot("Sigma_iw.ipt",wm,sigma)
  call splot("observables.ipt",u,beta,n,z)

  allocate(sigma_tau(0:L),fg_tau(0:L))
  open(100,file="Sigma_tau.ipt")
  do i=0,L
     read(100,*)z,sigma_tau(i)
  enddo
  close(100)

  allocate(SxG(0:L))
  call fftgf_iw2tau(fg,fg_tau(0:),beta)
  do i=0,L
     SxG(i) = sigma_tau(L-i)*fg(i)*beta/dble(L)
  enddo

  Epot=0.d0
  do i=1,L
     Epot=Epot+dreal(Sigma(i)*fg(i))
  enddo
  Epot=2.d0*Epot/beta
  doble=0.5d0*n - 0.25d0
  if(u > 0.01d0)doble=Epot/U + 0.5d0*n - 0.25d0
  print*,doble,Epot

  nk = square_lattice_momentum_distribution(Lk)
  call splot("nkVSepsk.ipt",epsik,nk)
contains

  function square_lattice_momentum_distribution(Lk) result(nk)
    integer                :: Lk
    integer                :: ik,i
    real(8)                :: nk(Lk)
    do ik=1,Lk
       fg=one/(xi*wm - epsik(ik) - sigma)
       nk(ik)= get_local_density(fg,beta)
    enddo
  end function square_lattice_momentum_distribution

  subroutine get_inital_sigma(self,file)
    complex(8),dimension(:) :: self
    real(8),dimension(size(self)) :: wm
    character(len=*)        :: file
    logical                 :: check
    inquire(file=file,exist=check)
    if(check)then
       print*,'Reading sigma'
       call sread(file,wm,self)
    else
       print*,"Using Hartree-Fock self-energy"
       print*,"===================================="
       self=zero !U*(n-1/2)
    endif
  end subroutine get_inital_sigma

end program hmipt_matsuara_2dsquare


subroutine trid(a, d, b, c, gam, alf, jmin, nn)

      use stel_kinds, only: dp
      use name1, only: mnd1
      use bounds, only: mlower, mupper
      use scalars, only: ns

      implicit none

      real(kind=dp), intent(in)    :: a  (ns,0:mnd1)
      real(kind=dp), intent(in)    :: b  (ns,0:mnd1)
      real(kind=dp), intent(inout) :: c  (ns,0:mnd1)
      real(kind=dp), intent(in)    :: d  (ns,0:mnd1)
      real(kind=dp), intent(out)   :: gam(0:mnd1,ns) ! only internal temporary storage
      real(kind=dp), intent(out)   :: alf(0:mnd1,ns) ! only internal temporary storage
      integer,       intent(in)    :: jmin(0:3)
      integer,       intent(in)    :: nn ! jmax

      integer :: imodes, in, in1, mn, i, i1, n2

      ! SOLVES B(I)*X(I-1)+D(I)*X(I)+A(I)*X(I+1)=C(I), I=IN,NN
      ! AND RETURNS ANSWER IN C(I)

      ! SEPARATE M=0 (IMODES=1), M=1 (IMODES=2), M>1 (IMODES=3)
      do imodes = 1, 3
        in  = jmin(imodes-1)
        in1 = in + 1

        do mn = mlower(imodes), mupper(imodes)
          gam(mn,in) = d(in,mn)
        end do

        do i = in1, nn
          do mn = mlower(imodes), mupper(imodes)
            alf(mn,i-1) = a(i-1,mn)/gam(mn,i-1)
            gam(mn,i  ) = d(i  ,mn) - b(i,mn)*alf(mn,i-1)
          end do
        end do

        do mn = mlower(imodes), mupper(imodes)
          c(in,mn) = c(in,mn)/gam(mn,in)
        end do

        do i = in1, nn
          do mn = mlower(imodes), mupper(imodes)
            c(i,mn) = (c(i,mn) - b(i,mn)*c(i-1,mn))/gam(mn,i)
          end do
        end do

        n2 = nn + in
        do i = in1, nn
          i1 = n2-i

          do mn = mlower(imodes), mupper(imodes)
            c(i1,mn) = c(i1,mn) - alf(mn,i1)*c(i1+1,mn)
          end do
        end do

      end do

      return
end