      SUBROUTINE SB08NY( DA, A, B, EPSB )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the coefficients of B(z) = A(1/z) * A(z) and a norm for
C     the accuracy of the computed coefficients.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     DA      (input) INTEGER
C             The degree of the polynomials A(z) and B(z).  DA >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (DA+1)
C             This array must contain the coefficients of the polynomial
C             A(z) in increasing powers of z.
C
C     B       (output) DOUBLE PRECISION array, dimension (DA+1)
C             This array contains the coefficients of the polynomial
C             B(z).
C
C     EPSB    (output) DOUBLE PRECISION
C             A value used for checking the accuracy of the computed
C             coefficients.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C     Supersedes Release 2.0 routine SB08BZ by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Laplace transform, polynomial operations, spectral factorization.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  THREE
      PARAMETER         ( THREE = 3.0D0 )
C     .. Scalar Arguments ..
      INTEGER           DA
      DOUBLE PRECISION  EPSB
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*)
C     .. Local Scalars ..
      INTEGER           I
C     .. External Functions ..
      DOUBLE PRECISION  DDOT, DLAMCH
      EXTERNAL          DDOT, DLAMCH
C     .. Executable Statements ..
C
      DO 20 I = 1, DA + 1
         B(I) = DDOT( DA-I+2, A(1), 1, A(I), 1 )
   20 CONTINUE
C
      EPSB = THREE*DLAMCH( 'Epsilon' )*B(1)
C
      RETURN
C *** Last line of SB08NY ***
      END


! calculate bulk's energy band using wannier TB method
! Copyright (c) 2010 QuanSheng Wu. All rights reserved.
  subroutine fermisurface3D

     use wmpi
     use para

     implicit none

     integer :: ik, i, j, l
     integer :: knv3
     integer :: nkx
     integer :: nky
     integer :: nkz

     integer :: ierr
     real(dp) :: kz
     real(Dp) :: k(3)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

     real(dp) :: kxmin, kxmax, kymin, kymax, kzmin, kzmax

     real(dp), allocatable :: kxyz(:,:)
     real(dp), allocatable :: W(:)
     real(dp), allocatable :: eigval(:,:)
     real(dp), allocatable :: eigval_mpi(:,:)

     nkx= Nk1
     nky= Nk2
     nkz= Nk3
     allocate(kxyz(3, nkx*nky*nkz))
     kxyz=0d0

     kxmin= 0.00d0/1d0
     kxmax= 1.00d0/1d0
     kymin= 0.00d0/1d0
     kymax= 1.00d0/1d0
     kzmin= 0.00d0/1d0
     kzmax= 1.00d0/1d0
     kz= 0.0d0
     ik =0
     do i= 1, nkx
        do j= 1, nky
        do l= 1, nkz
           ik =ik +1
           kxyz(1, ik)=kxmin+ (i-1)*(kxmax-kxmin)/dble(nkx-1)
           kxyz(2, ik)=kymin+ (j-1)*(kymax-kymin)/dble(nky-1)
           kxyz(3, ik)=kzmin+ (l-1)*(kzmax-kzmin)/dble(nkz-1)
        enddo
        enddo
     enddo

     knv3= nkx*nky*nkz
     allocate(     W(Num_wann))
     allocate(eigval(Num_wann, knv3))
     allocate(eigval_mpi(Num_wann, knv3))
     eigval_mpi= 0d0
     eigval= 0d0
     do ik= 1+cpuid, knv3, num_cpu
        if (cpuid==0.and. mod(ik,100)<3)write(stdout, *)'3DFS, ik, knv3', ik, knv3

        k(1) = kxyz(1, ik)
        k(2) = kxyz(2, ik)
        k(3) = kxyz(3, ik)

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk(k, Hamk_bulk)
        call eigensystem_c( 'N', 'U', Num_wann ,Hamk_bulk, W)
        eigval_mpi(:, ik)= W
     enddo

#if defined (MPI)
     call mpi_allreduce(eigval_mpi, eigval,size(eigval),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     eigval= eigval_mpi
#endif

     outfileindex= outfileindex+ 1
     if (cpuid==0)then
        open(unit=outfileindex,FILE='FS3D.bxsf',STATUS='UNKNOWN',FORM='FORMATTED')
        write(outfileindex,*) ' BEGIN_INFO'
        write(outfileindex,*) '      #'
        write(outfileindex,*) '      # this is a Band-XCRYSDEN-Structure-File'
        write(outfileindex,*) '      # for Fermi Surface Visualisation'
        write(outfileindex,*) '      #'
        write(outfileindex,*) ' END_INFO'
        write(outfileindex,*)
        write(outfileindex,*) ' BEGIN_BLOCK_BANDGRID_3D'
        write(outfileindex,*) 'from_wannier_code'
        write(outfileindex,*) ' BEGIN_BANDGRID_3D_fermi'
        write(outfileindex,*) num_wann
        write(outfileindex,*) nkx, nky, nkz
        write(outfileindex,*) '0.0 0.0 0.0'
        write(outfileindex,*) (Kua(i), i=1,3)
        write(outfileindex,*) (Kub(i), i=1,3)
        write(outfileindex,*) (Kuc(i), i=1,3)
        do i=1,num_wann
           write(outfileindex,*) 'BAND: ',i
           do ik=1, knv3
              write(outfileindex,'(2E16.8)') eigval(i, ik)
           enddo
        enddo
        write(outfileindex,*) 'END_BANDGRID_3D'
        write(outfileindex,*) ' END_BLOCK_BANDGRID_3D'
        close(outfileindex)

     endif

   return
   end subroutine fermisurface3D

! calculate bulk's energy band using wannier TB method
  subroutine fermisurface

     use wmpi
     use para

     implicit none

     integer :: ik, i, j, i1, i2
     integer :: knv3
     integer :: nkx
     integer :: nky

     integer :: ierr
     real(dp) :: kz
     real(Dp) :: k(3)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

     real(dp) :: kxmin, kxmax, kymin, kymax
     real(dp) :: zmin, zmax
     real(dp) :: kxmin_shape, kxmax_shape, kymin_shape, kymax_shape

     real(dp), allocatable :: kxy(:,:)
     real(dp), allocatable :: kxy_shape(:,:)

     real(dp), allocatable :: dos(:)
     real(dp), allocatable :: dos_mpi(:)

     complex(dp), allocatable :: ones(:,:)

     nkx= Nk
     nky= Nk
     allocate( kxy(3, nkx*nky))
     allocate( kxy_shape(3, nkx*nky))
     kxy=0d0
     kxy_shape=0d0

     ik =0
     do i= 1, nkx
        do j= 1, nky
           ik =ik +1
           kxy(:, ik)= K3D_start+ K3D_vec1*(i-1)/dble(nkx-1)+ K3D_vec2*(j-1)/dble(nky-1)
           kxy_shape(:, ik)= kxy(1, ik)* Kua+ kxy(2, ik)* Kub+ kxy(3, ik)* Kuc
        enddo
     enddo

     i1=1
     i2=2
     kxmin_shape=minval(kxy_shape(i1,:))
     kxmax_shape=maxval(kxy_shape(i1,:))
     kymin_shape=minval(kxy_shape(i2,:))
     kymax_shape=maxval(kxy_shape(i2,:))

     knv3= nkx*nky
     allocate( dos    (knv3))
     allocate( dos_mpi(knv3))
     dos    = 0d0
     dos_mpi= 0d0

     allocate(ones(Num_wann, Num_wann))
     ones= 0d0
     do i=1, Num_wann
        ones(i, i)= 1d0
     enddo

     do ik= 1+cpuid, knv3, num_cpu
        if (cpuid==0) write(stdout, *),'FS, ik, knv3' , ik, knv3

        k = kxy(:, ik)

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk(k, Hamk_bulk)

        Hamk_bulk= (E_arc -zi* eta_arc)* ones - Hamk_bulk
        call inv(Num_wann, Hamk_bulk)
        do i=1, Num_wann
           dos(ik)= dos(ik)+ aimag(Hamk_bulk(i, i))/pi
        enddo

     enddo

#if defined (MPI)
     call mpi_allreduce(dos,dos_mpi,size(dos),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     dos_mpi= dos
#endif

     outfileindex= outfileindex+ 1
     if (cpuid==0)then
        open(unit=outfileindex, file='fs.dat')

        do ik=1, knv3
           write(outfileindex, '(3f16.8)')kxy_shape(:, ik), log(dos_mpi(ik))
           if (mod(ik, nky)==0) write(outfileindex, *)' '
        enddo
        close(outfileindex)
     endif
     zmax= maxval(log(dos_mpi))
     zmin= minval(log(dos_mpi))

     !> minimum and maximum value of energy bands

     !> write script for gnuplot
     if (cpuid==0) then
        open(unit=101, file='fs.gnu')
        write(101, '(a)')"set encoding iso_8859_1"
        write(101, '(a)')'#set terminal  postscript enhanced color'
        write(101, '(a)')"#set output 'fs.eps'"
        write(101, '(3a)')'set terminal  pngcairo truecolor enhanced', &
           ' size 1920, 1680 font ",36"'
        write(101, '(a)')"set output 'fs.png'"
        write(101,'(a, f10.4, 2a, f10.4, a)') &
           'set palette defined ( ', zmin, ' "white", ', &
          '0 "black", ', zmax,'  "red" )'
        write(101, '(a)')'#set palette rgbformulae 33,13,10'
        write(101, '(a)')'unset ztics'
        write(101, '(a)')'unset key'
        write(101, '(a)')'set pm3d'
        write(101, '(a)')'#set view equal xyz'
        write(101, '(a)')'set view map'
        write(101, '(a)')'set border lw 3'
        write(101, '(a)')'#set xtics font ",24"'
        write(101, '(a)')'#set ytics font ",24"'
        write(101, '(a)')'set size ratio -1'
        write(101, '(a)')'unset xtics'
        write(101, '(a)')'unset ytics'
        write(101, '(a)')'set colorbox'
       !write(101, '(a, f10.5, a, f10.5, a)')'set xrange [', kxmin, ':', kxmax, ']'
       !write(101, '(a, f10.5, a, f10.5, a)')'set yrange [', kymin, ':', kymax, ']'
        write(101, '(a, f10.5, a, f10.5, a)')'set xrange [', kxmin_shape, ':', kxmax_shape, ']'
        write(101, '(a, f10.5, a, f10.5, a)')'set yrange [', kymin_shape, ':', kymax_shape, ']'
        write(101, '(a)')'set pm3d interpolate 2,2'
        write(101, '(2a)')"splot 'fs.dat' u 1:2:3 w pm3d"

        close(101)
     endif

   return
   end subroutine fermisurface

!  calculate bulk's energy band using wannier TB method
   subroutine gapshape3D

      use wmpi
      use para

      implicit none

      integer :: ik, i, j, l
      integer :: knv3
      integer :: nkx
      integer :: nky
      integer :: nkz

      integer :: ierr
      real(Dp) :: k(3)

      ! Hamiltonian of bulk system
      complex(Dp), allocatable :: Hamk_bulk(:, :)

      real(dp) :: kxmin_shape, kxmax_shape, kymin_shape
      real(dp) :: kymax_shape, kzmin_shape, kzmax_shape

      real(dp), allocatable :: kxy(:,:)
      real(dp), allocatable :: kxy_shape(:,:)

      real(dp), allocatable :: gap(:, :)
      real(dp), allocatable :: gap_mpi(:, :)
      real(dp), allocatable :: W(:)

      complex(dp), allocatable :: ones(:,:)

      nkx= Nk1
      nky= Nk2
      nkz= Nk3
      allocate( kxy(3, nkx*nky*nkz))
      allocate( kxy_shape(3, nkx*nky*nkz))
      kxy=0d0
      kxy_shape=0d0

      ik =0

      do i= 1, nkx
         do j= 1, nky
            do l= 1, nkz
               ik= ik+ 1
               kxy(:, ik)= K3D_start_cube+ K3D_vec1_cube*(i-1)/dble(nkx-1)  &
                         + K3D_vec2_cube*(j-1)/dble(nky-1)  &
                         + K3D_vec3_cube*(l-1)/dble(nkz-1)
               kxy_shape(:, ik)= kxy(1, ik)* Kua+ kxy(2, ik)* Kub+ kxy(3, ik)* Kuc
            enddo
         enddo
      enddo

      kxmin_shape=minval(kxy_shape(1,:))
      kxmax_shape=maxval(kxy_shape(1,:))
      kymin_shape=minval(kxy_shape(2,:))
      kymax_shape=maxval(kxy_shape(2,:))
      kzmin_shape=minval(kxy_shape(3,:))
      kzmax_shape=maxval(kxy_shape(3,:))

      knv3= nkx*nky*nkz
      allocate( gap    (3, knv3))
      allocate( gap_mpi(3, knv3))
      gap    = 0d0
      gap_mpi= 0d0

      allocate(W(Num_wann))
      allocate(ones(Num_wann, Num_wann))
      allocate(Hamk_bulk(Num_wann, Num_wann))
      W= 0d0
      ones= 0d0
      do i=1, Num_wann
         ones(i, i)= 1d0
      enddo

      if (Numoccupied> Num_wann) then
         stop 'Numoccupied should less than Num_wann'
      endif

      do ik= 1+cpuid, knv3, num_cpu
         if (cpuid==0) write(stdout, *) 'Gap3D, ik, knv3', ik, knv3

         k(1) = kxy(1, ik)
         k(2) = kxy(2, ik)
         k(3) = kxy(3, ik)

         ! calculation bulk hamiltonian
         Hamk_bulk= 0d0
         call ham_bulk(k, Hamk_bulk)

         call eigensystem_c( 'N', 'U', Num_wann ,Hamk_bulk, W)
         gap(1, ik)= W(Numoccupied+1)- W(Numoccupied)
         gap(2, ik)= W(Numoccupied)
         gap(3, ik)= W(Numoccupied+1)

      enddo

      gap_mpi = 0d0
#if defined (MPI)
      call mpi_allreduce(gap,gap_mpi,size(gap),&
                        mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     gap_mpi= gap
#endif

      if (cpuid==0)then
         open(unit=15, file='GapCube.dat')
         write(15, '(80a16)')'kx (1/A)', 'ky (1/A)', 'kz (1/A)', &
            'Energy gap', 'Ev', 'Ec', &
            'k1 (2pi/a)', 'k2 (2pi/b)', 'k3 (2pi/c)'
         do ik=1, knv3
            if (abs(gap_mpi(1, ik))< Gap_threshold) then
               write(15, '(80f16.8)') kxy_shape(:, ik), (gap_mpi(:, ik)), kxy(:, ik)
            endif
         enddo
         close(15)
      endif

     !!> minimum and maximum value of energy bands
     !
     !zmax= maxval((gap_mpi))
     !zmin= minval((gap_mpi))

      !> write script for gnuplot
      outfileindex= outfileindex+ 1
      if (cpuid==0) then
         open(unit=outfileindex, file='GapCube.gnu')
         write(outfileindex, '(a)')"set encoding iso_8859_1"
         write(outfileindex, '(a)')'#set terminal  postscript enhanced color'
         write(outfileindex, '(a)')"#set output 'gap.eps'"
         write(outfileindex, '(3a)')'set terminal  png      truecolor enhanced', &
            ' size 1920, 1680 font ",36"'
         write(outfileindex, '(a)')"set output 'GapCube.png'"
         write(outfileindex, '(a)')'unset ztics'
         write(outfileindex, '(a)')'unset key'
         write(outfileindex, '(a)')'set ticslevel 0'
         write(outfileindex, '(a)')'#set view equal xyz'
         write(outfileindex, '(a)')'set border lw 3'
         write(outfileindex, '(a)')'set xlabel "k_x"'
         write(outfileindex, '(a)')'set ylabel "k_y"'
         write(outfileindex, '(a)')'set zlabel "k_z"'
         write(outfileindex, '(a)')'set xtics nomirror scale 0.5'
         write(outfileindex, '(a)')'set ytics nomirror scale 0.5'
         write(outfileindex, '(a)')'set ztics nomirror scale 0.5'
         write(outfileindex, '(a)')'set xtics offset  0.0,-1.0 , 0'
         write(outfileindex, '(a)')'set ytics offset -2.5,   0 , 0'
         write(outfileindex, '(a)')'set size ratio -1'
         write(outfileindex, '(a)')'set view 60, 140, 1, 1'
         write(outfileindex, '(a, f10.5, a, f10.5, a)')'set xrange [', kxmin_shape, ':', kxmax_shape, ']'
         write(outfileindex, '(a, f10.5, a, f10.5, a)')'set yrange [', kymin_shape, ':', kymax_shape, ']'
         write(outfileindex, '(a, f10.5, a, f10.5, a)')'set zrange [', kzmin_shape, ':', kzmax_shape, ']'
         write(outfileindex, '(2a)')"splot 'GapCube.dat' u 1:2:3 w p pt 7 ps 2"
         close(outfileindex)

      endif

      return
   end subroutine gapshape3D

!  calculate bulk's energy band using wannier TB method
   subroutine gapshape

      use wmpi
      use para

      implicit none

      integer :: ik, i, j
      integer :: knv3
      integer :: nkx
      integer :: nky

      integer :: ierr, i1, i2
      real(Dp) :: k(3)

      ! Hamiltonian of bulk system
      complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

      real(dp) :: zmin, zmax
      real(dp) :: kxmin_shape, kxmax_shape, kymin_shape, kymax_shape

      real(dp), allocatable :: kxy(:,:)
      real(dp), allocatable :: kxy_shape(:,:)

      real(dp), allocatable :: gap(:, :)
      real(dp), allocatable :: gap_mpi(:, :)
      real(dp), allocatable :: W(:)

      complex(dp), allocatable :: ones(:,:)

      nkx= Nk
      nky= Nk
      allocate( kxy(3, nkx*nky))
      allocate( kxy_shape(3, nkx*nky))
      kxy=0d0
      kxy_shape=0d0

      ik =0
      do i= 1, nkx
         do j= 1, nky
            ik =ik +1
            kxy(:, ik)= K3D_start+ K3D_vec1*(i-1)/dble(nkx-1)+ K3D_vec2*(j-1)/dble(nky-1)
            kxy_shape(:, ik)= kxy(1, ik)* Kua+ kxy(2, ik)* Kub+ kxy(3, ik)* Kuc
         enddo
      enddo

      i1=2
      i2=3
      kymin_shape=minval(kxy_shape(i2,:))
      kymax_shape=maxval(kxy_shape(i2,:))
      kxmin_shape=minval(kxy_shape(i1,:))
      kxmax_shape=maxval(kxy_shape(i1,:))

      knv3= nkx*nky
      allocate( gap    ( 9, knv3))
      allocate( gap_mpi( 9, knv3))
      gap    = 0d0
      gap_mpi= 0d0

      allocate(W(Num_wann))
      allocate(ones(Num_wann, Num_wann))
      W= 0d0
      ones= 0d0
      do i=1, Num_wann
         ones(i, i)= 1d0
      enddo

      if (Numoccupied> Num_wann) then
         stop 'Numoccupied should less than Num_wann'
      endif

      do ik= 1+cpuid, knv3, num_cpu
         if (cpuid==0)write(stdout, *)'Gap plane', ik, knv3

         k(1) = kxy(1, ik)
         k(2) = kxy(2, ik)
         k(3) = kxy(3, ik)

         !> calculation bulk hamiltonian
         Hamk_bulk= 0d0
         call ham_bulk(k, Hamk_bulk)

         !> diagonalization
         call eigensystem_c( 'N', 'U', Num_wann ,Hamk_bulk, W)
         gap(1, ik)= W(Numoccupied+1)- W(Numoccupied)
         gap(2:9 , ik)= W(Numoccupied-3:Numoccupied+4)

      enddo

#if defined (MPI)
      call mpi_allreduce(gap,gap_mpi,size(gap),&
                        mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     gap_mpi= gap
#endif

      outfileindex= outfileindex+ 1
      if (cpuid==0)then
         open(unit=outfileindex, file='GapPlane.dat')

         write(outfileindex, '(100a16)')'% kx', 'ky', 'kz', 'gap', 'Ev2', 'Ev1', 'Ec1', 'Ec2', 'k1', 'k2', 'k3'
         do ik=1, knv3
            write(outfileindex, '(30f16.8)')kxy_shape(:, ik), (gap_mpi(:, ik)), kxy(:, ik)
            if (mod(ik, nky)==0) write(outfileindex, *)' '
         enddo
         close(outfileindex)
      endif

      outfileindex= outfileindex+ 1
      if (cpuid==0)then
         open(unit=outfileindex, file='gap2d.dat')
         write(outfileindex, '(100a16)')'% kx', 'ky', 'kz', 'gap', 'Ev2', 'Ev1', 'Ec1', 'Ec2', 'k1', 'k2', 'k3'
         do ik=1, knv3
            if (abs(gap_mpi(1, ik))< 0.10d0) then
               write(outfileindex, '(8f16.8)')kxy_shape(:, ik), (gap_mpi(:, ik)), kxy(:, ik)
            endif
         enddo
         close(outfileindex)
      endif

      outfileindex= outfileindex+ 1
      if (cpuid==0)then
         open(unit=outfileindex, file='GapPlane_matlab.dat')
         write(outfileindex, '(100a16)')'% kx', 'ky', 'kz', 'gap', 'Ev2', 'Ev1', 'Ec1', 'Ec2', 'k1', 'k2', 'k3'
         do ik=1, knv3
            write(outfileindex, '(30f16.8)')kxy_shape(:, ik), (gap_mpi(:, ik)), kxy(:, ik)
         enddo
         close(outfileindex)
      endif

      !> minimum and maximum value of energy bands

      zmax= maxval(gap_mpi(1, :))
      zmin= minval(gap_mpi(1, :))

      !> write script for gnuplot
      outfileindex= outfileindex+ 1
      if (cpuid==0) then
         open(unit=outfileindex, file='GapPlane.gnu')
         write(outfileindex, '(a)')"set encoding iso_8859_1"
         write(outfileindex, '(a)')'#set terminal  postscript enhanced color'
         write(outfileindex, '(a)')"#set output 'GapPlane.eps'"
         write(outfileindex, '(3a)')'#set terminal  pngcairo   truecolor enhanced', &
            '  size 1920, 1680 font ",60"'
         write(outfileindex, '(3a)')'set terminal  png   truecolor enhanced', &
            ' size 1920, 1680 font ",60"'
         write(outfileindex, '(a)')"set output 'GapPlane.png'"
         write(outfileindex,'(a, f10.4, a, f10.4, a, f10.4, a)') &
            'set palette defined ( ', zmin, ' "black", ', &
            (zmin+zmax)/20d0,' "orange", ',zmax,'  "white" )'
         write(outfileindex, '(a)')"set origin 0.10, 0.0"
         write(outfileindex, '(a)')"set size 0.85, 1.0"
         write(outfileindex, '(a)')'unset ztics'
         write(outfileindex, '(a)')'unset key'
         write(outfileindex, '(a)')'set pm3d'
         write(outfileindex, '(a)')'set view map'
         write(outfileindex, '(a)')'set border lw 3'
         write(outfileindex, '(a)')'#set size ratio -1'
         write(outfileindex, '(a)')'set title "Gap in k plane"'
         write(outfileindex, '(a)')'set xtics nomirror scale 0.5'
         write(outfileindex, '(a)')'set ytics nomirror scale 0.5'
         write(outfileindex, '(a)')"set xlabel 'k (1/{\305})'"
         write(outfileindex, '(a)')"set ylabel 'k (1/{\305})'"
         write(outfileindex, '(a)')'set colorbox'
         write(outfileindex, '(a)')'set xrange [ ] noextend'
         write(outfileindex, '(a)')'set yrange [ ] noextend'
         write(outfileindex, '(a)')'set pm3d interpolate 2,2'
         write(outfileindex, '(2a)')"splot 'GapPlane.dat' u 1:2:4 w pm3d"

         close(outfileindex)
      endif

      return
   end subroutine gapshape

   !> get fermilevel for the given hamiltonian
   subroutine get_fermilevel
      use wmpi
      use para
      implicit none

      integer :: i1
      integer :: i2
      integer :: i3
      integer :: io
      integer :: ik

      !> number of k points
      integer :: knv3

      integer :: ierr
      integer :: iter
      integer :: itermax

      !> fermi level
      real(dp) :: EF

      real(dp) :: k(3)

      real(dp) ::  Beta

      real(dp) :: lmin
      real(dp) :: lmax
      real(dp) :: tot

      !> fermi-dirac distribution function
      real(dp), external :: fermi

      !> kpoint coordinates
      real(dp), allocatable :: kpoints(:, :)

      !> eigen value for each kpoint
      real(dp), allocatable :: W(:)
      real(dp), allocatable :: eigvals(:, :)
      real(dp), allocatable :: eigvals_mpi(:, :)

      complex(dp), allocatable :: ham(:, :)

      knv3= Nk*Nk*Nk

      allocate(W(Num_wann))
      allocate(eigvals(Num_wann, knv3))
      allocate(eigvals_mpi(Num_wann, knv3))
      allocate(ham(Num_wann, Num_wann))
      allocate(kpoints(3, knv3))
      eigvals= 0d0
      eigvals_mpi= 0d0
      ham= 0d0
      kpoints= 0d0
      Beta= 200d0

      ik= 0
      do i1=1, Nk
      do i2=1, Nk
      do i3=1, Nk
         ik= ik+ 1
         kpoints(1, ik)= (i1-1d0)/dble(Nk)
         kpoints(2, ik)= (i2-1d0)/dble(Nk)
         kpoints(3, ik)= (i3-1d0)/dble(Nk)
      enddo
      enddo
      enddo

      do ik=1+ cpuid, knv3, num_cpu

         ham= 0d0
         k= kpoints(:, ik)
         call ham_bulk(k, ham)
         call eigensystem_c( 'N', 'U', num_wann, ham, W)
         eigvals_mpi(:, ik)= W
      enddo ! ik

#if defined (MPI)
      call mpi_allreduce(eigvals_mpi, eigvals, size(eigvals), &
                         mpi_dp, mpi_sum, mpi_cmw, ierr)
#else
     eigvals= eigvals_mpi
#endif

      ! using bisection algorithm to search the fermi level
      iter= 0
      itermax= 100
      tot= 9999d0
      lmin= minval(eigvals)
      lmax= maxval(eigvals)
      if (cpuid==0) print *, 'Emin= ', lmin
      if (cpuid==0) print *, 'Emax= ', lmax
      do while( abs(tot- Ntotch).gt. eps6 .and. iter.lt.itermax)

         iter= iter+ 1

         EF= (lmin+ lmax)* half

         tot= 0d0
         do ik=1, knv3
            do io=1, Num_wann
               tot= tot+ fermi(eigvals(io, ik)- EF, Beta)
            enddo ! io
         enddo ! ik
         tot= tot/dble(knv3)

         if (tot > Ntotch)then
            lmax= EF
         else
            lmin= EF
         endif

         if (cpuid==0) then
             write(stdout, 100)iter, tot-Ntotch, EF, '  Charge: ', tot
         endif
      100   format(2x,">iter",i4,2x,"diff:",f12.6,2x,"EF: ",f12.6,a,f12.6)

      enddo ! bisection

      E_fermi= EF

      return
   end subroutine get_fermilevel

   !------------+------------+------------+------------+------------+--------+!
   ! calculate the Fermi-Dirac distribution
   !------------+------------+------------+------------+------------+--------+!
   function fermi(omega, Beta) result(value)

      use para
      implicit none

      ! >> inout variables
      real(dp), intent(in) :: omega
      real(dp), intent(in) :: Beta

      ! return value
      real(dp) :: value

      ! avoid numerical instability
      if (beta*omega .ge. 20d0) then
         value = zero
      elseif (beta*omega.le. -20d0)then
         value = one
      else
         value= one/(one+exp(beta*omega))
      endif

      return
   end function fermi


      subroutine tcspgrid(
     >   x_newgrid,nx_new,y_newgrid,ny_new,z_newgrid,nz_new,
     >   f_new,if1,if2,
     >   nx,xpkg,ny,ypkg,nz,zpkg,fspl,inf4,inf5,iwarn,ier)
c
c  regrid a spline function f defined vs. x,y,z as in xpkg,ypkg,zpkg
c  to a new grid, given by x_newgrid, y_newgrid, z_newgrid
c
c  set warning flag if the range of x_newgrid or y_newgrid or z_newgrid
c   exceeds the range of the original xpkg or ypkg or zpkg.
c
c  (xpkg,ypkg,zpkg arrays  -- axis data, see genxpkg subroutine)
c
c  input:
c
      real x_newgrid(nx_new)            ! new x grid
      real y_newgrid(ny_new)            ! new y grid
      real z_newgrid(nz_new)            ! new z grid
c
c  output:
c
      integer if1,if2                   ! 1st dimensions of f_new
      real f_new(if1,if2,nz_new)        ! f evaluated on this grid
c
c  input:
c
      integer nx                        ! size of old grid
      real xpkg(nx,4)                   ! old grid "package"
      integer ny                        ! size of old grid
      real ypkg(ny,4)                   ! old grid "package"
      integer nz                        ! size of old grid
      real zpkg(nz,4)                   ! old grid "package"
c
      integer inf4                      ! array dimension
      integer inf5                      ! array dimension
      real fspl(4,4,4,inf4,inf5,nz)     ! spline coefficients of f
c
c  output:
c  condition codes, =0 for normal exit
c
      integer iwarn                     ! =1 if new grid points out of range
      integer ier                       ! =1 if there is an argument error
c
c--------------------------------------------
c  local
c
      real ytmp(nx_new),ztmp(nx_new)
      integer ict(10)
c
      data ict/1,0,0,0,0,0,0,0,0,0/
c
c--------------------------------------------
c
      do iz=1,nz_new
         ztmp=y_newgrid(iz)
         do iy=1,ny_new
            ytmp=y_newgrid(iy)
            call tcspvec(ict,nx_new,x_newgrid,ytmp,ztmp,
     >         nx_new,f_new(1,iy,iz),
     >         nx,xpkg,ny,ypkg,nz,zpkg,fspl,inf4,inf5,iwarn,ier)
         enddo
      enddo
c
      return
      end


      SUBROUTINE AUTCORF(X,N,CXX,CN,LAGH1,XMEAN)
C

C
C     PROGRAM 5.1.1   AUTO CORRELATION
C-----------------------------------------------------------------------
C     ** DESIGNED BY H. AKAIKE, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** PROGRAMMED BY E. ARAHATA, THE INSTITUTE OF STATISTICAL MATHEMAT
C         TOKYO
C     ** DATE OF THE LATEST REVISION: MARCH 25, 1977
C     ** THIS PROGRAM WAS ORIGINALLY PUBLISHED IN
C         "DAINAMIKKU SISTEMU NO TOKEI-TEKI KAISEKI TO SEIGYO (STATISTICA
C         ANALYSIS AND CONTROL OF DYNAMIC SYSTEMS)" BY H. AKAIKE AND
C         T. NAKAGAWA, SAIENSU-SHA, TOKYO, 1972 (IN JAPANESE)
C-----------------------------------------------------------------------
C     THIS PROGRAM REQUIRES FOLLOWING INPUTS:
C     N: LENGTH OF DATA
C     LAGH: MAXIMUM LAG
C     DFORM: INPUT FORMAT SPECIFICATION STATEMENT IN ONE CARD,
C     FOR EXAMPLE
C     (8F10.4)
C     (X(I),I=1,N): ORIGINAL DATA.
C     THE OUTPUTS ARE AUTOCOVARIANCES (CXX(I); I=0,LAGH) AND
C     AUTO CORRELATIONS (NORMALIZED COVARIANCES).
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: AUTCORF
C
cxx      IMPLICIT REAL*8 (A-H,O-Z)
c      DIMENSION X(5000),CXX(1001),CN(1001)
c	 REAL*4 DFORM
c      DIMENSION  DFORM(20)
cxx      DIMENSION X(N),X1(N),CXX(LAGH1),CN(LAGH1)
      INTEGER :: N, LAGH1
      REAL(8) :: X(N), CXX(LAGH1), CN(LAGH1), XMEAN
      REAL(8) :: X1(N), CX0
C
C     INPUT / OUTPUT DATA FILE OPEN
c	CHARACTER(100) DFNAM
c	CALL SETWND
c	DFNAM='autcor.out'
c      CALL FLOPN3(DFNAM,NFL)
c      IF (NFL.EQ.0) GO TO 999
C     INITIAL CONDITION INPUT AND PRINT OUT
c      READ(5,1) N,LAGH
c      WRITE(6,50)
c      WRITE(6,51)
c      WRITE(6,52) N,LAGH
C     INPUT FORMAT SPECIFICATION
c      READ(5,4) (DFORM(I),I=1,20)
c    4 FORMAT(20A4)
C     ORIGINAL DATA INPUT AND PRINT OUT
c      READ(5,DFORM) (X(I),I=1,N)
c      WRITE(6,53)
c      WRITE(6,54)
c      DO 220 I=1,N
c  220 WRITE(6,55) I,X(I)
      DO 220 I=1,N
cxx  220 X1(I)=X(I)
      X1(I)=X(I)
  220 CONTINUE
C     MEAN DELETION
      CALL DMEADL(X1,N,XMEAN)
C     AUTO COVARIANCE COMPUTATION
c      LAGH1=LAGH+1
      CALL CROSCO(X1,X1,N,CXX,LAGH1)
C     NORMALIZATION
      CX0=CXX(1)
      CALL CORNOM(CXX,CN,LAGH1,CX0,CX0)
C     AUTO COVARIANCE PRINT OUT
c      WRITE(6,162) N,LAGH,XMEAN
c      WRITE(6,163)
c      CALL PRCOL2(CXX,CN,1,LAGH1,1)
C     AUTO COVARIANCE PUNCH OUT
c      WRITE(7,1) N,LAGH
c      WRITE(7,2) (CXX(I),I=1,LAGH1)
c	CALL FLCLS3(NFL)
c  999 CONTINUE
c    1 FORMAT(10I5)
c    2 FORMAT(4D20.10)
c   50 FORMAT(1H ,13HPROGRAM 5.1.1,3X,16HAUTO CORRELATION)
c   51 FORMAT(1H ,17HINITIAL CONDITION)
c   52 FORMAT(1H ,2HN=,I5,5X,5HLAGH=,I5)
c   53 FORMAT(1H ,13HORIGINAL DATA)
c   54 FORMAT(1H ,4X,1HI,6X,4HX(I))
c   55 FORMAT(1H ,I5,2X,F10.4)
cCC  162 FORMAT(//1H ,14HAUTOCOVARIANCE,5X,6HCXX(I),5X,2HN=,I5,5X,5HLAGH=,I
c  162 FORMAT(1H ,14HAUTOCOVARIANCE,5X,6HCXX(I),5X,2HN=,I5,5X,5HLAGH=,I
c     A5,5X,5HMEAN=,D15.5)
c  163 FORMAT(1H ,4X,1HI,5X,6HCXX(I),8X,10HNORMALIZED)
      RETURN
      END


C Output from Public domain Ratfor, version 1.0
      subroutine sinerp(abd,ld4,nk,p1ip,p2ip,ldnk,flag)
c
C Purpose :  Computes Inner Products between columns of L^{-1}
C            where L = abd is a Banded Matrix with 3 subdiagonals

C In R, only called in one place, from sslrvg() [ ./sslvrg.f ] with flag = 0

C The algorithm works in two passes:
C
C               Pass 1 computes (cj,ck) k=j,j-1,j-2,j-3 ;  j=nk, .. 1
C               Pass 2 computes (cj,ck) k <= j-4  (If flag == 1 ).
C
C               A refinement of Elden's trick is used.
c Args
      integer ld4,nk,ldnk,flag
      DOUBLE precision abd(ld4,nk), p1ip(ld4,nk), p2ip(ldnk,nk)
c Locals
      integer i,j,k
      DOUBLE precision  wjm3(3),wjm2(2),wjm1(1),c0,c1,c2,c3
c
c     unnecessary initialization of c1 c2 c3 to keep g77 -Wall happy
c
      c1 = 0.0d0
      c2 = 0.0d0
      c3 = 0.0d0
C
C Pass 1
      wjm3(1)=0d0
      wjm3(2)=0d0
      wjm3(3)=0d0
      wjm2(1)=0d0
      wjm2(2)=0d0
      wjm1(1)=0d0
      do 100 i=1,nk
         j=nk-i+1
         c0 = 1d0/abd(4,j)
         if(j.le.nk-3)then
            c1 = abd(1,j+3)*c0
            c2 = abd(2,j+2)*c0
            c3 = abd(3,j+1)*c0
         else if(j.eq.nk-2)then
            c1 = 0d0
            c2 = abd(2,j+2)*c0
            c3 = abd(3,j+1)*c0
         else if(j.eq.nk-1)then
            c1 = 0d0
            c2 = 0d0
            c3 = abd(3,j+1)*c0
         else if(j.eq.nk)then
            c1 = 0d0
            c2 = 0d0
            c3 = 0d0
         endif
         p1ip(1,j) = 0d0- (c1*wjm3(1)+c2*wjm3(2)+c3*wjm3(3))
         p1ip(2,j) = 0d0- (c1*wjm3(2)+c2*wjm2(1)+c3*wjm2(2))
         p1ip(3,j) = 0d0- (c1*wjm3(3)+c2*wjm2(2)+c3*wjm1(1))
         p1ip(4,j) = c0**2 + c1**2*wjm3(1) + 2d0*c1*c2*wjm3(2)+
     &        2d0*c1*c3*wjm3(3) + c2**2*wjm2(1) + 2d0*c2*c3*wjm2(2) +
     &        c3**2*wjm1(1)
         wjm3(1)=wjm2(1)
         wjm3(2)=wjm2(2)
         wjm3(3)=p1ip(2,j)
         wjm2(1)=wjm1(1)
         wjm2(2)=p1ip(3,j)
         wjm1(1)=p1ip(4,j)
 100  continue

      if(flag.ne.0) then

C     ____ Pass 2 _____  Compute p2ip  [never from R's code!]
         do 120 i=1,nk
            j=nk-i+1
C           for(k=1;k<=4 & j+k-1<=nk;k=k+1) { p2ip(.) = .. }:
            do k=1,4
               if(j+k-1 .gt. nk) goto 120
               p2ip(j,j+k-1) = p1ip(5-k,j)
            end do
 120     continue

         do 170 i=1,nk
            j=nk-i+1
c           for(k=j-4;k>=1;k=k-1){
            if(j-4 .ge. 1) then
               do k= j-4,1, -1
                  c0 = 1d0/abd(4,k)
                  c1 = abd(1,k+3)*c0
                  c2 = abd(2,k+2)*c0
                  c3 = abd(3,k+1)*c0
                  p2ip(k,j)= 0d0 - ( c1*p2ip(k+3,j) + c2*p2ip(k+2,j) +
     &                 c3*p2ip(k+1,j) )
               end do
            endif
 170     continue
      endif
      return
      end


      SUBROUTINE MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L,
     $                   LDL, CS, LCS, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Cholesky factor and the generator and/or the
C     Cholesky factor of the inverse of a symmetric positive definite
C     (s.p.d.) block Toeplitz matrix T, defined by either its first
C     block row, or its first block column, depending on the routine
C     parameter TYPET. Transformation information is stored.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the output of the routine, as follows:
C             = 'G':  only computes the generator G of the inverse;
C             = 'R':  computes the generator G of the inverse and the
C                     Cholesky factor R of T, i.e., if TYPET = 'R',
C                     then R'*R = T, and if TYPET = 'C', then R*R' = T;
C             = 'L':  computes the generator G and the Cholesky factor L
C                     of the inverse, i.e., if TYPET = 'R', then
C                     L'*L = inv(T), and if TYPET = 'C', then
C                     L*L' = inv(T);
C             = 'A':  computes the generator G, the Cholesky factor L
C                     of the inverse and the Cholesky factor R of T;
C             = 'O':  only computes the Cholesky factor R of T.
C
C     TYPET   CHARACTER*1
C             Specifies the type of T, as follows:
C             = 'R':  T contains the first block row of an s.p.d. block
C                     Toeplitz matrix; if demanded, the Cholesky factors
C                     R and L are upper and lower triangular,
C                     respectively, and G contains the transposed
C                     generator of the inverse;
C             = 'C':  T contains the first block column of an s.p.d.
C                     block Toeplitz matrix; if demanded, the Cholesky
C                     factors R and L are lower and upper triangular,
C                     respectively, and G contains the generator of the
C                     inverse. This choice results in a column oriented
C                     algorithm which is usually faster.
C             Note:   in the sequel, the notation x / y means that
C                     x corresponds to TYPET = 'R' and y corresponds to
C                     TYPET = 'C'.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of rows / columns in T, which should be equal
C             to the blocksize.  K >= 0.
C
C     N       (input)  INTEGER
C             The number of blocks in T.  N >= 0.
C
C     T       (input/output)  DOUBLE PRECISION array, dimension
C             (LDT,N*K) / (LDT,K)
C             On entry, the leading K-by-N*K / N*K-by-K part of this
C             array must contain the first block row / column of an
C             s.p.d. block Toeplitz matrix.
C             On exit, if INFO = 0, then the leading K-by-N*K / N*K-by-K
C             part of this array contains, in the first K-by-K block,
C             the upper / lower Cholesky factor of T(1:K,1:K), and in
C             the remaining part, the Householder transformations
C             applied during the process.
C
C     LDT     INTEGER
C             The leading dimension of the array T.
C             LDT >= MAX(1,K),    if TYPET = 'R';
C             LDT >= MAX(1,N*K),  if TYPET = 'C'.
C
C     G       (output)  DOUBLE PRECISION array, dimension
C             (LDG,N*K) / (LDG,2*K)
C             If INFO = 0 and JOB = 'G', 'R', 'L', or 'A', the leading
C             2*K-by-N*K / N*K-by-2*K part of this array contains, in
C             the first K-by-K block of the second block row / column,
C             the lower right block of L (necessary for updating
C             factorizations in SLICOT Library routine MB02DD), and
C             in the remaining part, the generator of the inverse of T.
C             Actually, to obtain a generator one has to set
C                 G(K+1:2*K, 1:K) = 0,    if TYPET = 'R';
C                 G(1:K, K+1:2*K) = 0,    if TYPET = 'C'.
C
C     LDG     INTEGER
C             The leading dimension of the array G.
C             LDG >= MAX(1,2*K),  if TYPET = 'R' and
C                                    JOB = 'G', 'R', 'L', or 'A';
C             LDG >= MAX(1,N*K),  if TYPET = 'C' and
C                                    JOB = 'G', 'R', 'L', or 'A';
C             LDG >= 1,           if JOB = 'O'.
C
C     R       (output)  DOUBLE PRECISION array, dimension (LDR,N*K)
C             If INFO = 0 and JOB = 'R', 'A', or 'O', then the leading
C             N*K-by-N*K part of this array contains the upper / lower
C             Cholesky factor of T.
C             The elements in the strictly lower / upper triangular part
C             are not referenced.
C
C     LDR     INTEGER
C             The leading dimension of the array R.
C             LDR >= MAX(1,N*K),  if JOB = 'R', 'A', or 'O';
C             LDR >= 1,           if JOB = 'G', or 'L'.
C
C     L       (output)  DOUBLE PRECISION array, dimension (LDL,N*K)
C             If INFO = 0 and JOB = 'L', or 'A', then the leading
C             N*K-by-N*K part of this array contains the lower / upper
C             Cholesky factor of the inverse of T.
C             The elements in the strictly upper / lower triangular part
C             are not referenced.
C
C     LDL     INTEGER
C             The leading dimension of the array L.
C             LDL >= MAX(1,N*K),  if JOB = 'L', or 'A';
C             LDL >= 1,           if JOB = 'G', 'R', or 'O'.
C
C     CS      (output)  DOUBLE PRECISION array, dimension (LCS)
C             If INFO = 0, then the leading 3*(N-1)*K part of this
C             array contains information about the hyperbolic rotations
C             and Householder transformations applied during the
C             process. This information is needed for updating the
C             factorizations in SLICOT Library routine MB02DD.
C
C     LCS     INTEGER
C             The length of the array CS.  LCS >= 3*(N-1)*K.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -16,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,(N-1)*K).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction algorithm failed. The Toeplitz matrix
C                   associated with T is not (numerically) positive
C                   definite.
C
C     METHOD
C
C     Householder transformations and modified hyperbolic rotations
C     are used in the Schur algorithm [1], [2].
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C                               3 2
C     The algorithm requires 0(K N ) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Chemnitz, Germany, June 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 2000,
C     February 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB, TYPET
      INTEGER           INFO, K, LCS, LDG, LDL, LDR, LDT, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*),
     $                  T(LDT,*)
C     .. Local Scalars ..
      INTEGER           I, IERR, MAXWRK, STARTI, STARTR, STARTT
      LOGICAL           COMPG, COMPL, COMPR, ISROW
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLACPY, DLASET, DPOTRF, DTRSM, MB02CX, MB02CY,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      COMPL = LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' )
      COMPG = LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'R' ) .OR. COMPL
      COMPR = LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) .OR.
     $        LSAME( JOB, 'O' )
      ISROW = LSAME( TYPET, 'R' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( COMPG .OR. COMPR ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN
         INFO = -2
      ELSE IF ( K.LT.0 ) THEN
         INFO = -3
      ELSE IF ( N.LT.0 ) THEN
         INFO = -4
      ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR.
     $                   ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN
         INFO = -6
      ELSE IF ( LDG.LT.1 .OR.
     $           ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K )
     $                 .OR. ( .NOT.ISROW .AND. LDG.LT.N*K ) ) ) ) THEN
         INFO = -8
      ELSE IF ( LDR.LT.1 .OR. ( COMPR .AND. ( LDR.LT.N*K ) ) ) THEN
         INFO = -10
      ELSE IF ( LDL.LT.1 .OR. ( COMPL .AND. ( LDL.LT.N*K ) ) ) THEN
         INFO = -12
      ELSE IF ( LCS.LT.3*( N - 1 )*K ) THEN
         INFO = -14
      ELSE IF ( LDWORK.LT.MAX( 1, ( N - 1 )*K ) ) THEN
         DWORK(1) = MAX( 1, ( N - 1 )*K )
         INFO = -16
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02CD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( K, N ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      MAXWRK = 1
      IF ( ISROW ) THEN
C
C        T is the first block row of a block Toeplitz matrix.
C        Bring T to proper form by triangularizing its first block.
C
         CALL DPOTRF( 'Upper', K, T, LDT, IERR )
         IF ( IERR.NE.0 )  THEN
C
C           Error return:  The matrix is not positive definite.
C
            INFO = 1
            RETURN
         END IF
C
         IF ( N.GT.1 )
     $      CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K,
     $                  (N-1)*K, ONE, T, LDT, T(1,K+1), LDT )
C
C        Initialize the output matrices.
C
         IF ( COMPG ) THEN
            CALL DLASET( 'All', 2*K, N*K, ZERO, ZERO, G, LDG )
            CALL DLASET( 'All', 1, K, ONE, ONE, G(K+1,1), LDG+1 )
            CALL DTRSM(  'Left', 'Upper', 'Transpose', 'NonUnit', K, K,
     $                   ONE, T, LDT, G(K+1,1), LDG )
            IF ( N.GT.1 )
     $         CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, G(K+1,K+1),
     $                      LDG )
            CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, G, LDG )
         END IF
C
         IF ( COMPL ) THEN
            CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, L, LDL )
         END IF
C
         IF ( COMPR ) THEN
            CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR )
         END IF
C
C        Processing the generator.
C
         IF ( COMPG ) THEN
C
C           Here we use G as working array for holding the generator.
C           T contains the second row of the generator.
C           G contains in its first block row the second row of the
C           inverse generator.
C           The second block row of G is partitioned as follows:
C
C           [ First block of the inverse generator, ...
C             First row of the generator, ...
C             The rest of the blocks of the inverse generator ]
C
C           The reason for the odd partitioning is that the first block
C           of the inverse generator will be thrown out at the end and
C           we want to avoid reordering.
C
C           (N-1)*K locations of DWORK are used by SLICOT Library
C           routine MB02CY.
C
            DO 10  I = 2, N
               STARTR = ( I - 1 )*K + 1
               STARTI = ( N - I + 1 )*K + 1
               STARTT = 3*( I - 2 )*K + 1
C
C              Transformations acting on the generator:
C
               CALL MB02CX( 'Row', K, K, K, G(K+1,K+1), LDG,
     $                      T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK,
     $                      LDWORK, IERR )
C
               IF ( IERR.NE.0 )  THEN
C
C                 Error return:  The matrix is not positive definite.
C
                  INFO = 1
                  RETURN
               END IF
C
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               IF ( N.GT.I )  THEN
                  CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K,
     $                         G(K+1,2*K+1), LDG, T(1,STARTR+K), LDT,
     $                         T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK,
     $                         LDWORK, IERR )
                  MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               END IF
C
               IF ( COMPR ) THEN
                  CALL DLACPY( 'Upper', K, (N-I+1)*K, G(K+1,K+1), LDG,
     $                         R(STARTR,STARTR), LDR)
               END IF
C
C              Transformations acting on the inverse generator:
C
               CALL DLASET( 'All', K, K, ZERO, ZERO, G(K+1,STARTI),
     $                      LDG )
               CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1),
     $                      LDG, G(1,STARTR), LDG, T(1,STARTR), LDT,
     $                      CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K,
     $                      G(K+1,STARTI), LDG, G, LDG, T(1,STARTR),
     $                      LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               IF ( COMPL ) THEN
                  CALL DLACPY( 'All', K, (I-1)*K, G(K+1,STARTI), LDG,
     $                         L(STARTR,1), LDL )
                  CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG,
     $                         L(STARTR,(I-1)*K+1), LDL )
               END IF
   10       CONTINUE
C
         ELSE
C
C           Here R is used as working array for holding the generator.
C           Again, T contains the second row of the generator.
C           The current row of R contains the first row of the
C           generator.
C
            IF ( N.GT.1 )
     $         CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, R(K+1,K+1),
     $                      LDR )
C
            DO 20  I = 2, N
               STARTR = ( I - 1 )*K + 1
               STARTT = 3*( I - 2 )*K + 1
               CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR,
     $                      T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK,
     $                      LDWORK, IERR )
               IF ( IERR.NE.0 )  THEN
C
C                 Error return:  The matrix is not positive definite.
C
                  INFO = 1
                  RETURN
               END IF
C
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               IF ( N.GT.I ) THEN
                  CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K,
     $                         R(STARTR,STARTR+K), LDR, T(1,STARTR+K),
     $                         LDT, T(1,STARTR), LDT, CS(STARTT), 3*K,
     $                         DWORK, LDWORK, IERR )
                  MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
                  CALL DLACPY( 'Upper', K, (N-I)*K, R(STARTR,STARTR),
     $                          LDR, R(STARTR+K,STARTR+K), LDR )
               END IF
   20       CONTINUE
C
         END IF
C
      ELSE
C
C        T is the first block column of a block Toeplitz matrix.
C        Bring T to proper form by triangularizing its first block.
C
         CALL DPOTRF( 'Lower', K, T, LDT, IERR )
         IF ( IERR.NE.0 )  THEN
C
C           Error return:  The matrix is not positive definite.
C
            INFO = 1
            RETURN
         END IF
C
         IF ( N.GT.1 )
     $      CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit',
     $                  (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT )
C
C        Initialize the output matrices.
C
         IF ( COMPG ) THEN
            CALL DLASET( 'All', N*K, 2*K, ZERO, ZERO, G, LDG )
            CALL DLASET( 'All', 1, K, ONE, ONE, G(1,K+1), LDG+1 )
            CALL DTRSM(  'Right', 'Lower', 'Transpose', 'NonUnit', K, K,
     $                   ONE, T, LDT, G(1,K+1), LDG )
            IF ( N.GT.1 )
     $         CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, G(K+1,K+1),
     $                      LDG )
            CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, G, LDG )
         END IF
C
         IF ( COMPL ) THEN
            CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, L, LDL )
         END IF
C
         IF ( COMPR ) THEN
            CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR )
         END IF
C
C        Processing the generator.
C
         IF ( COMPG ) THEN
C
C           Here we use G as working array for holding the generator.
C           T contains the second column of the generator.
C           G contains in its first block column the second column of
C           the inverse generator.
C           The second block column of G is partitioned as follows:
C
C           [ First block of the inverse generator; ...
C             First column of the generator; ...
C             The rest of the blocks of the inverse generator ]
C
C           The reason for the odd partitioning is that the first block
C           of the inverse generator will be thrown out at the end and
C           we want to avoid reordering.
C
C           (N-1)*K locations of DWORK are used by SLICOT Library
C           routine MB02CY.
C
            DO 30  I = 2, N
               STARTR = ( I - 1 )*K + 1
               STARTI = ( N - I + 1 )*K + 1
               STARTT = 3*( I - 2 )*K + 1
C
C              Transformations acting on the generator:
C
               CALL MB02CX( 'Column', K, K, K, G(K+1,K+1), LDG,
     $                      T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK,
     $                      LDWORK, IERR )
C
               IF ( IERR.NE.0 )  THEN
C
C                 Error return:  The matrix is not positive definite.
C
                  INFO = 1
                  RETURN
               END IF
C
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               IF ( N.GT.I ) THEN
                  CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K,
     $                         K, G(2*K+1,K+1), LDG, T(STARTR+K,1), LDT,
     $                         T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK,
     $                         LDWORK, IERR )
                  MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               END IF
C
               IF ( COMPR ) THEN
                  CALL DLACPY( 'Lower', (N-I+1)*K, K, G(K+1,K+1), LDG,
     $                         R(STARTR,STARTR), LDR)
               END IF
C
C              Transformations acting on the inverse generator:
C
               CALL DLASET( 'All', K, K, ZERO, ZERO, G(STARTI,K+1),
     $                      LDG )
               CALL MB02CY( 'Column', 'Triangular', K, K, K, K,
     $                      G(1,K+1), LDG, G(STARTR,1), LDG,
     $                      T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK,
     $                      LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K,
     $                      G(STARTI,K+1), LDG, G, LDG, T(STARTR,1),
     $                      LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               IF ( COMPL ) THEN
                  CALL DLACPY( 'All', (I-1)*K, K, G(STARTI,K+1), LDG,
     $                         L(1,STARTR), LDL )
                  CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG,
     $                         L((I-1)*K+1,STARTR), LDL )
               END IF
   30       CONTINUE
C
         ELSE
C
C           Here R is used as working array for holding the generator.
C           Again, T contains the second column of the generator.
C           The current column of R contains the first column of the
C           generator.
C
            IF ( N.GT.1 )
     $         CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, R(K+1,K+1),
     $                      LDR )
C
            DO 40  I = 2, N
               STARTR = ( I - 1 )*K + 1
               STARTT = 3*( I - 2 )*K + 1
               CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR,
     $                      T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK,
     $                      LDWORK, IERR )
               IF ( IERR.NE.0 )  THEN
C
C                 Error return:  The matrix is not positive definite.
C
                  INFO = 1
                  RETURN
               END IF
C
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
               IF ( N.GT.I ) THEN
                  CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K,
     $                         K, R(STARTR+K,STARTR), LDR,
     $                         T(STARTR+K,1), LDT, T(STARTR,1), LDT,
     $                         CS(STARTT), 3*K, DWORK, LDWORK, IERR )
                  MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
                  CALL DLACPY( 'Lower', (N-I)*K, K, R(STARTR,STARTR),
     $                         LDR, R(STARTR+K,STARTR+K), LDR )
               END IF
   40       CONTINUE
C
         END IF
      END IF
C
      DWORK(1) = MAXWRK
C
      RETURN
C
C *** Last line of MB02CD ***
      END


!##############################################################################
! PROGRAM market4
!
! ## The static GE model with unemployment
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog03_05m.f90"

program market4

    use globals
    use toolbox

    implicit none
    real*8 :: x(5), L(2), K(2), Y(2), Xd(2), Ybarn
    real*8 :: q(2), p(2), PX, w, wn, r, rn, U, ell
    real*8 :: ur
    logical :: check

    ! initial guess
    x(1) = 0.8d0
    x(2) = 0.3d0
    x(3) = 0.7d0
    x(4) = 0.26d0
    x(5) = 0.1d0

    ! find market equilibrium
    call fzero(x, markets, check)

    ! check whether fzero converged
    if(check)then
        write(*,'(a/)')'Error in fzero !!!'
        stop
    endif

    ! copy producer prices
    q(1)    = 1d0
    q(2)    = x(1)
    w       = x(2)
    r       = x(3)

    ! set tax rates (uncomment respective line for different tables)
    taur    = x(4)
    !tauw    = x(4)
    !tauc(1) = x(4)
    !tauc(2) = x(4)

    ! copy the unempoyment rate
    ur      = x(5)

    ! calculate consumer prices
    p    = q*(1d0+tauc)
    PX   = p(1)*alpha(1)/sum(alpha)+p(2)*alpha(2)/sum(alpha)
    tauu = PX*B*ur/(w*(1-ur))
    wn   = w*(1d0-tauw-tauu)*(1-ur)+PX*B*ur
    rn   = r*(1d0-taur)

    ! calculate other economic variables
    Ybarn = wn*Tbar+rn*Kbar
    Xd    = alpha*Ybarn/p
    Y(1)  = Xd(1)+G
    Y(2)  = Xd(2)
    ell   = (1d0-alpha(1)-alpha(2))*Ybarn/wn
    L     = beta*q*Y/w
    K     = (1d0-beta)*q*Y/r
    U     = Xd(1)**alpha(1)*Xd(2)**alpha(2)*ell**(1d0-alpha(1)-alpha(2))

    ! Output
    write(*,'(/a)')'GOODS MARKET 1 :'
    write(*,'(6(a,f6.2,2x))')' X1 =',Xd(1),' G  =',G,' Y1 =',Y(1), &
        ' q1 =',q(1),' p1 =',p(1),' tc1=',tauc(1)

    write(*,'(/a)')'GOODS MARKET 2 :'
    write(*,'(6(a,f6.2,2x))')' X2 =',Xd(2),' G  =',0d0,' Y2 =',Y(2), &
        ' q2 =',q(2),' p2 =',p(2),' tc2=',tauc(2)

    write(*,'(/a)')'LABOR MARKET :'
    write(*,'(6(a,f6.2,2x))')' L1 =',L(1),' L2 =',L(2),' T-F=',Tbar-ell, &
        ' w  =',w,' wn =',wn, ' tw =',tauw

    write(*,'(/a)')'CAPITAL MARKET :'
    write(*,'(6(a,f6.2,2x))')' K1 =',K(1),' K2 =',K(2),' K  =',Kbar, &
        ' r  =',r,' rn =',rn, ' tr =',taur

    write(*,'(/a)')'GOVERNMENT :'
    write(*,'(6(a,f6.2,2x))')' tc1=',tauc(1)*q(1)*Xd(1), &
        ' tc2=',tauc(2)*q(2)*Xd(2),' tw =',tauw*w*(1-ur)*(Tbar-ell), &
        ' tr =',taur*r*Kbar,' G  =',q(1)*G

    write(*,'(/a)')'Unemployment:'
    write(*,'(6(a,f6.2,2x))')'  ur =',ur,' tauu=',tauu,'  PX =',PX, &
        ' PXB =',PX*B,' wn  =',w*(1-tauw-tauu)

    write(*,'(/a)')'UTILITY :'
    write(*,'(a,f6.2,2x)')' U  =',U

end program


!MJW - 19/11/18
module gaussian_expansion
implicit none
save

real(8), parameter :: pi = 3.14159265359d0

contains

!----------------------------------------------------------------------------------------!

!Numerical Recipes
!Gauss Legendre grid points and weights
subroutine gaulegf(x1, x2, x, w, n)
  integer, intent(in) :: n
  real(8), intent(in) :: x1, x2
  real(8), dimension(n), intent(out) :: x, w
  integer :: i, j, m
  real(8) :: p1, p2, p3, pp, xl, xm, z, z1
  real(8), parameter :: eps=3.d-14

  pp = 0.0d0
  m = (n+1)/2
  xm = 0.5d0*(x2+x1)
  xl = 0.5d0*(x2-x1)
  do i=1,m
    z = cos(3.141592654d0*(i-0.25d0)/(n+0.5d0))
    z1 = 0.0
    do while(abs(z-z1) .gt. eps)
      p1 = 1.0d0
      p2 = 0.0d0
      do j=1,n
        p3 = p2
        p2 = p1
        p1 = ((2.0d0*j-1.0d0)*z*p2-(j-1.0d0)*p3)/j
      end do
      pp = n*(z*p1-p2)/(z*z-1.0d0)
      z1 = z
      z = z1 - p1/pp
    end do
    x(i) = xm - xl*z
    x(n+1-i) = xm + xl*z
    w(i) = (2.0d0*xl)/((1.0d0-z*z)*pp*pp)
    w(n+1-i) = w(i)
  end do

end subroutine gaulegf

!----------------------------------------------------------------------------------------!

!Numerical Recipes
!Associated Legendre polynomial
real(8) function plgndr(l, m, x)
  integer, intent(in) :: l, m
  real(8), intent(in) :: x
  integer :: i, ll
  real(8) :: fact, oldfact, pll, pmm, pmmp1, omx2
  real(8), parameter :: pi = 3.14159265359d0

  pll = 0.0d0
  !if(m.lt.0.or.m.gt.l.or.abs(x).gt.1.) pause 'bad arguments in plgndr'

  pmm=1.0d0
  if (m .gt. 0) then
    omx2 = (1.d0-x)*(1.d0+x)
    fact = 1.d0
    do i = 1, m
      pmm = pmm*omx2*fact/(fact+1.d0)
      fact = fact + 2.d0
    end do
  end if

  pmm = sqrt((2*m + 1)*pmm/(4.d0*pi))
  if (mod(m, 2) .eq. 1) pmm = -pmm
  if (l .eq. m) then
    plgndr = pmm
  else
    pmmp1 = x*sqrt(2.d0*m + 3.d0)*pmm
    if (l .eq. m+1) then
      plgndr = pmmp1
    else
      oldfact=sqrt(2.d0*m + 3.d0)
    do ll = m+2, l
      fact = sqrt((4.d0*ll**2 - 1.d0)/(ll**2-m**2))
      pll = (x*pmmp1-pmm/oldfact)*fact
      oldfact = fact
      pmm = pmmp1
      pmmp1 = pll
    end do
      plgndr = pll
    end if
  end if

end function plgndr

!----------------------------------------------------------------------------------------!

!Hyperbolic cotangent
real(8) function coth(x)
  real(8), intent(in) :: x

  coth = (1.0d0 + exp(-2.0d0*x))/(1.0d0 - exp(-2.0d0*x))

end function coth

!----------------------------------------------------------------------------------------!

!Hyperbolic cotangent in quad precision
real(kind=16) function cothquad(x)
  real(kind=16), intent(in) :: x

  cothquad = (1.0e0_16 + exp(-2.0e0_16*x))/(1.0e0_16 - exp(-2.0e0_16*x))

end function cothquad

!----------------------------------------------------------------------------------------!

!Partial expansion
subroutine fsub(r, sigma, rij, lmax, f)
  real(8), intent(in) :: r, sigma, rij
  real(8), dimension(0:lmax), intent(out) :: f
  integer, intent(in) :: lmax
  real(8) :: alpha, frev
  real(8), parameter :: eps = 1.0d-3
  integer :: i

  alpha = rij/sigma**2
  f = 0.0d0

  if (abs(r - rij) >= 5.0d0*sigma) then
    return
  end if

  if (r <= eps) then
    return
  end if

  if (rij <= eps) then
    f(0) = exp(-r**2/(2.0d0*sigma**2))*r
    return
  end if

  !l=0
  f(0) = exp(-0.5d0*(r - rij)**2/sigma**2)
  f(0) = f(0) - exp(-0.5d0*(r + rij)**2/sigma**2)
  f(0) = 0.5d0*f(0)/alpha

  if (lmax == 0) then
    return
  end if

  !l=1
  if (alpha*r >= eps) then !exact
    f(1) = f(0)*(coth(alpha*r) - 1.0d0/(r*alpha))
  else !first three terms in Taylor series
    f(1) = f(0)*(alpha*r/3.0d0 - (alpha*r)**2/45.0d0 + (alpha*r)**5/945.0d0)
  end if

  !in = in-1 - (2(n-1) + 1)in-1/x
  do i = 2, lmax
    f(i) = f(i-2) - (2.0d0*dble(i - 1) + 1.0d0)*f(i-1)/(alpha*r)
    frev = f(i) + (2.0d0*dble(i - 1) + 1.0d0)*f(i-1)/(alpha*r)
    frev = f(i-1) + (2.0d0*dble(i - 2) + 1.0d0)*frev/(alpha*r)
    if (i >= 3 .and. abs(frev - f(i-3)) >= 1.0d-100) then
!      print *, 'Iteration in l terminated early because of numerical instability'
      if (f(i)/f(0) > 1.0d-8) cycle
      f(i:lmax) = 0.0d0
      exit
    end if
  end do

end subroutine fsub

!----------------------------------------------------------------------------------------!

!Partial expansion in quad precision
subroutine fsubquad(r2, sigma2, rij2, lmax, f2)
  real(kind=8), intent(in) :: r2, sigma2, rij2
  real(kind=8), dimension(0:lmax), intent(out) :: f2
  integer, intent(in) :: lmax
  real(kind=16) :: r, sigma, rij
  real(kind=16), dimension(0:lmax) :: f
  real(kind=16) :: alpha, frev
  real(kind=16), parameter :: eps = 1.0e-5_16
  integer :: i

  r = real(r2, 16)
  sigma = real(sigma2, 16)
  rij = real(rij2, 16)
  alpha = rij/sigma**2
  f = 0.0e0_16

  if (abs(r - rij) >= 5.0_16*sigma) then
    f2 = dble(f)
    return
  end if

  if (r <= eps) then
    f2 = dble(f)
    return
  end if

  if (rij <= eps) then
    f(0) = exp(-r**2/(2.0e0_16*sigma**2))*r
    f2 = dble(f)
    return
  end if

  !l=0
  f(0) = exp(-0.5e0_16*(r - rij)**2/sigma**2)
  f(0) = f(0) - exp(-0.5e0_16*(r + rij)**2/sigma**2)
  f(0) = 0.5e0_16*f(0)/alpha

  if (lmax == 0) then
    f2 = dble(f)
    return
  end if

  !l=1
  if (alpha*r >= eps) then !exact
    f(1) = f(0)*(cothquad(alpha*r) - 1.0e0_16/(r*alpha))
  else !first three terms in Taylor series
    f(1) = f(0)*(alpha*r/3.0e0_16 - (alpha*r)**2/45.0e0_16 + (alpha*r)**5/945.0e0_16)
  end if

  !in = in-1 - (2(n-1) + 1)in-1/x
  do i = 2, lmax
    f(i) = f(i-2) - (2.0e0_16*real(i - 1, 16) + 1.0e0_16)*f(i-1)/(alpha*r)
    frev = f(i) + (2.0e0_16*real(i - 1, 16) + 1.0e0_16)*f(i-1)/(alpha*r)
    frev = f(i-1) + (2.0e0_16*real(i - 2, 16) + 1.0e0_16)*frev/(alpha*r)
    if (i >= 3 .and. abs(frev - f(i-3)) >= 1.0e-100_16) then
!      print *, 'Warning: iteration in l terminated early because of numerical instability'
      if (f(i)/f(0) > 1.0e-8_16) cycle
      f(i:lmax) = 0.0d0
      exit
    end if
  end do

  f2 = dble(f)

end subroutine fsubquad

!----------------------------------------------------------------------------------------!

!Full expansion
subroutine f2sub(f, nmax, lmax, cost, f2)
  real(8), dimension(0:nmax, 0:lmax), intent(in) :: f
  real(8), intent(in) :: cost
  integer, intent(in) :: nmax, lmax
  real(8), dimension(0:nmax, 0:lmax, 0:lmax), intent(out) :: f2
  integer :: i, j

  do i = 0, lmax
    do j = 0, lmax
      f2(:, i, j) = f(:, i)*plgndr(i, j, cost)
    end do
  end do

end subroutine f2sub

!----------------------------------------------------------------------------------------!

end module gaussian_expansion


c     # ------------------------------------------------------------
c     #
c     # Mapping terms needed to compute exact solution
c     #
c     # NOTE: All arguments to routines here should be in computational
c     # coordinates (x,y) in [0,1]x[0,1].  Mapping from brick domains
c     # to [0,1]x[0,1] should be done from calling routines, as should
c     # any mappings that convert from an orthogonal coordinate system
c     # to a non-orthogonal system.
c     # ------------------------------------------------------------

      subroutine map_covariant_basis(blockno,x,y,t1,t2)
      implicit none

      double precision x,y,t1(3),t2(3)
      integer blockno
      double precision t(3,2),tinv(3,2), tderivs(3,2,2)
      integer flag, k

      integer*8 cont, get_context

      cont = get_context()

c     # Compute covariant derivatives only
      flag = 1
      call fclaw2d_map_c2m_basis(cont, blockno,
     &                 x,y, t, tinv, tderivs, flag)

      do k = 1,3
          t1(k) = t(k,1)
          t2(k) = t(k,2)
      enddo

      end

      subroutine map_contravariant_basis(blockno,x,y,t1inv,t2inv)
      implicit none

      double precision x,y
      integer blockno
      double precision t1inv(3), t2inv(3)
      double precision t(3,2), tinv(3,2), tderivs(3,2,2)
      integer k, flag

      integer*8 cont, get_context

      cont = get_context()

      flag = 3
      call fclaw2d_map_c2m_basis(cont, blockno,
     &             x,y, t, tinv,tderivs, flag)

      do k = 1,3
          t1inv(k) = tinv(k,1)
          t2inv(k) = tinv(k,2)
      end do

      end

      subroutine map_christoffel_sym(blockno,x,y,g)
      implicit none

      double precision x, y
      integer blockno
      double precision g(2,2,2)

      double precision map_dot

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision t(3,2), tinv(3,2), tderivs(3,2,2)
      double precision s(3,2), tij(3), sk(3)

      integer i,j,k, m, flag

      integer*8 cont, get_context

      cont = get_context()

c     # Compute covariant and derivatives
      flag = 7
      call fclaw2d_map_c2m_basis(cont, blockno,
     &             x,y, t, tinv,tderivs, flag)

      do k = 1,3
          s(k,1) = tinv(k,1)
          s(k,2) = tinv(k,2)
      end do

      do i = 1,2
          do j = 1,2
              do k = 1,2
                  do m = 1,3
                      tij(m) = tderivs(m,i,j)
                      sk(m) = s(m,k)
                  enddo
                  g(i,j,k) = map_dot(tij,sk)
              enddo
          enddo
      enddo

      end

      double precision function map_divergence(blockno,x,y)
      implicit none

      double precision x,y
      integer blockno

      double precision u(2), uderivs(4), g(2,2,2)
      double precision D11, D22

c     # Get g(i,j,k), g = \Gamma(i,j,k)
      call velocity_derivs(blockno,x,y,u,uderivs)
      call map_christoffel_sym(blockno,x,y,g)

      D11 = uderivs(1) + u(1)*g(1,1,1) + u(2)*g(1,2,1)
      D22 = uderivs(4) + u(1)*g(2,1,2) + u(2)*g(2,2,2)

      map_divergence = D11 + D22

      end

c     # ----------------------------------------------------------------
c     # Utility functions
c     # ----------------------------------------------------------------

      subroutine map_cross(u,v,uxv,w)
      implicit none

      double precision u(3),v(3),uxv(3),w, map_dot
      integer k

      uxv(1) =   u(2)*v(3) - u(3)*v(2)
      uxv(2) = -(u(1)*v(3) - u(3)*v(1))
      uxv(3) =   u(1)*v(2) - u(2)*v(1)

      w = map_dot(uxv,uxv)
      w = sqrt(w)

      end

      double precision function map_dot(u,v)
      implicit none

      double precision u(3),v(3)

      map_dot = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)

      end


program  make_mesh
! program to develop simple mesh that is regularly spaced but with triangular elements
!
!use utils
implicit none
type :: grid
integer :: Nnodes,K
integer :: n_stk,n_dip
integer :: QuakeElemNo,QuakeNodesNo
real :: ds,fwidth,flen
integer,dimension(14) :: mid_ele_pt
       real,allocatable,dimension(:,:) :: dist
       integer,allocatable,dimension(:,:) ::  EtoV,EToE,EToF
       integer,allocatable,dimension(:) :: QuakeElem,QuakeNodes
       integer :: QuakeBorder_NodesNo, QuakeBorder_ElemNo
       integer,allocatable,dimension(:) :: QuakeBorder_Nodes, QuakeBorder_Elem
       real,allocatable,dimension(:) :: VX,VY,VZ,area,slip
end type grid
type(grid) :: elem
NAMELIST / GENERAL  / n_x, n_z, dx, dz

real :: dx,dz
integer :: n_x, n_z

open(11,file='input_file',status='old',action='read')
read(11,nml=GENERAL,END=200)
close(11)
!n_x = 40  ! number of nodes along strike
!n_z = 25   ! number of nodes down dip
!dx  = 1000.
!dz  = 1000.
call create_mesh(n_x,n_z,dx,dz,elem)

!call output_mesh(elem)

call write_inp_file(elem)

return
! error message on reading input file
200 write(*,*) 'ERROR reading input_file'
stop

contains

!==============================================================================
subroutine create_mesh(n_x,n_z,dx,dz,elem)
implicit none
integer, intent(in) :: n_x,n_z
real, intent(in) :: dx,dz
real :: num
type(grid) :: elem

integer :: i,j,inx

elem%Nnodes = n_x*n_z
elem%K = (n_x-1)*(n_z-1)*2
allocate(elem%VX(elem%Nnodes),elem%VY(elem%Nnodes),elem%VZ(elem%Nnodes))
allocate(elem%EToV(elem%K,3))

inx = 0
do j = 1,n_z
  do i = 1,n_x
         inx = inx+1
         elem%VX(inx) = dx*float(i-1)
         elem%VY(inx) = dz*float(j-1)
         elem%VZ(inx) = 0.
    enddo
enddo

call random_seed
inx = 1
do i = 1,(n_x)*(n_z-1)
! there are two options for splitting the element
  if (mod(i,n_x) /= 0 ) then
    call random_number(num)        ! randomly split of cell
    if (num <0.5) then
      elem%EToV(inx,:)   =   (/ i, i+1, n_x+i+1/)
      elem%EToV(inx+1,:) =   (/ i, n_x+i+1, n_x+i/)
    else
        elem%EToV(inx,:)   =   (/ n_x+i, i, i+1 /)
        elem%EToV(inx+1,:) =   (/ n_x+i, i+1, i+1+n_x /)
    endif

    inx = inx+2
    endif
enddo

end subroutine create_mesh
!==============================================================================
subroutine output_mesh(elem)
implicit none
type(grid) :: elem
integer :: i

open(12,file='nodes_test.txt',form = 'formatted', action = 'write')
do i = 1,elem%Nnodes
	 write(12,*) i,elem%VX(i),elem%VY(i),elem%VZ(i)
enddo
close(12)

open(12,file='elements_test.txt',form = 'formatted', action = 'write')
do i = 1,elem%K
	 write(12,*) i,elem%EToV(i,1),elem%EToV(i,2),elem%EToV(i,3)
enddo
close(12)

end subroutine output_mesh
!==============================================================================
!  ########################################################################################
!***********************************************************
subroutine write_inp_file(elem)
implicit none
type(grid) :: elem
integer :: i

open(12,file='test.inp',form = 'formatted', action = 'write')
write(12,*) '* HEADING'
write(12,*) 'homemade'
do i = 1,6
       write(12,*)  '**'
enddo
write(12,*) '* Nodes'

do i = 1,elem%Nnodes
       write(12,*) i,elem%VX(i),elem%VY(i),elem%VZ(i)
enddo
write(12,*) '**'
write(12,*) '** '
write(12,*) '*Elements'
do i = 1,elem%K
	 write(12,*) i,elem%EToV(i,1),elem%EToV(i,2),elem%EToV(i,3)
enddo
write(12,*) '**'
close(12)
end subroutine write_inp_file
!==============================================================================
end program make_mesh