module generate_structures
   use auxilary_subroutines
   use global_module
implicit none
contains

!---------------------------------------------------------------
!Determine the total number of possible combinations
!-------------------------------------------------------------------
!
subroutine number_of_combinations(d_grid1, n21, many_combs)
implicit none
!
integer(kind=16), intent(in) :: d_grid1
integer(kind=16), intent(in) :: n21
integer(kind=16) :: n_combs1
character(len=1), intent(out) :: many_combs
!
n_combs1 = combination_x_of_p(n21,d_grid1)
write(25,*) 'number of combinations:', n_combs1
!
if (n_combs1 .le. 100000) then
   many_combs = 'N'
else if (n_combs1 .gt. 100000) then
   many_combs = 'Y'
end if
!
end subroutine number_of_combinations
!
!---------------------------------------------------------------
!create molecular structures by placing atoms on different points
!on the grid
!---------------------------------------------------------------
!
subroutine grid_to_molecule_small(n_grid, n2, method1, V2, grid1, c2, m2, combination1)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
integer, intent(in) :: n_grid
integer, intent(in) :: n2 ! dimension of the grid
character(len=17), intent(in) :: method1
logical, intent(in) :: V2 !vanadium 1 or 2
real(dp), allocatable, dimension(:,:), intent(inout) :: grid1
real(dp), allocatable, dimension(:,:), intent(out) :: combination1
integer, intent(inout) :: c2, m2
integer, allocatable, dimension(:) :: combination, past_combs, previous_runs
integer, allocatable, dimension(:,:) :: combinations
real(dp), allocatable, dimension(:,:) :: coords2
integer :: i, j, x, y, k, a, l, n, n_combs, io, random_comb, r, ncombs
real(dp), dimension(1) :: random
character(len=1) :: n_run
!
!-------------------------------------------------------
!creates the molecular coordinates
!-------------------------------------------------------
!-------------------------------------------------------
!generats the structures as combinations of the number of
!atoms in the molecule and the number of points on the grid,
!in lexicographical order:
!--------------------------------------------------------
!---------------------------------------------------------
!Let's take as an example, a grid of five atoms, used to
!form a molecule of three. The combinations are:
!
!123 |molecule(3) < 5, so we we increase it by one
!124 |molecule(3) < 5, so we we increase it by one
!125 |molecule(3) = 5, molecule(2) < 4, so we increase
!     molecule(2) by one, and molecule(3) = molecule(2) + 1
!134 |molecule(3) < 5, so we we increase it by one
!135 |molecule(3) < 5, so we we increase it by one
!145 |molecule(3) = 5, molecule(2) = 4, but molecule(1) < 3
!     so, molecule(1) = molecule(1) + 1
!     molecule(2) = molecule(1)(new) + 1, or, molecule(1)(old) + 2
!     molecule(3) = molecule(2)(new) + 1, or, molecule(1)(old) + 3
!
!234 |molecule(3) < 5, so we we increase it by one
!235 |molecule(3) = 5, molecule(2) < 4, so we increase
!     molecule(2) by one, and molecule(3) = molecule(2) + 1
!245 |molecule(3) = 5, molecule(2) = 4, but molecule(1) < 3
!     so, molecule(1) = molecule(1) + 1
!     molecule(2) = molecule(1)(new) + 1, or, molecule(1)(old) + 2
!     molecule(3) = molecule(2)(new) + 1, or, molecule(1)(old) + 3
!345 |molecule(1) = 3 --> stop the loop.
!
!-------------------------------------------------------
!
allocate ( combination(n2), coords2(n2,3), combination1(n2,3) )
!
do i = 1, n2
   combination(i) = i !123
end do
!
do x = 1, n2
   do y = 1, 3
      combination1(x,y) = grid1(combination(x),y)
   end do
end do
!
call write_to_file(combination1, method1, n2, V2, c2, m2)
!
!--------------------------------------------------
!now, we generate all of the other combinations:
!--------------------------------------------------
!
open(unit=4, file='combination.txt', status='replace', action='write')
!
a = 2
k = n2 + 1 !drives the increase of the last integer in the
!          combination, combination(m)
!
do while (combination(1) .lt. (n_grid - n2 + 1))
   if (combination(n2) .lt. n_grid) then
      combination(n2) = k !124 125 135 235
      k = k + 1
      !
      write(4,*) combination
      !
   else if (combination(n2) .eq. n_grid) then
      do j = 1, n2
         l = n2 - j
         if ( combination(j) .eq. (n_grid - l) ) then
            combination(j-1) = combination(j-1) + 1
            do n = j, n2
               combination(n) = combination(n-1) + 1 !134 145 234 245
                                                                !345
            end do
            k = combination(n2) + 1
            !
            write(4,*) combination
            !
            exit
         end if
      end do
   end if
   a = a + 1
end do
!
close(4)
!
!-------------------------------------------------------
!to store these combinations in a matrix:
!---------
!
!-----------------------------------------------------------
!to identify the combinations from previous runs:
!-------------------------------------------------------------
!
write(*,*) 'is this the first run? [Y/N]'
read(*,*) n_run
if (n_run == 'N') then
   open(unit=30, file='previous_runs.txt', status='old', action='read')
   ncombs = 0
   do
      read(30,*,iostat=io) i
      if (io /= 0) exit
      ncombs = ncombs + 1
   end do
   write(*,*) 'ncombs', ncombs
   close(30)
!
   open(unit=31, file='previous_runs.txt', status='old', action='read')
   allocate(previous_runs(ncombs))
   do i = 1, ncombs
      read(31,*) previous_runs(i)
   end do
   close(31)

   do i = 1, ncombs
      r = previous_runs(i)
      past_combs(r) = r
   end do
end if
!
!----------------------------------------------------------------
!randomly select a certain number of combinations and print
!the corresponding structures.
!----------------------------------------------------------------
!
open(unit=12, file='random_comb.txt', status='replace', action='write')
open(unit=32, file='previous_runs.txt', status='replace', action='write', &
   position="append")
!
a = 1
do while ((m2 .lt. 700) .and. (a .lt. n_combs))
   call random_number(random)
   random_comb = nint(random(1) * n_combs)
   if (random_comb == 0) cycle !because it gives an error
   if (random_comb == 1) cycle
   if (random_comb == past_combs(random_comb)) cycle !because we have
!                                                     already submitted this
!                                                     job for optimization.
   do i = 1, n2
      combination(i) = combinations(random_comb,i)
   end do
   write(12,*) a, random_comb, '- combination:', combination
   do x = 1, n2
      do y = 1, 3
         coords2(x,y) = grid1(combination(x),y)
      end do
   end do
   call write_to_file (coords2, method1, n2, V2, c2, m2)
   past_combs(random_comb) = random_comb !to make sure that it is not
!                                         repeated in the same run
   write(32,*) random_comb
   a = a + 1
end do
close(12)
close(32)
!
deallocate(combination, combinations, past_combs, coords2)
deallocate(grid1)
close(9)
!
end subroutine grid_to_molecule_small
!
subroutine grid_to_molecule_large(n_grid2, n22, method1, V22, grid2, c22, m22, combination1)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
integer, intent(in) :: n_grid2, n22 ! dimension of the grid
character(len=17), intent(in) :: method1
logical, intent(in) :: V22 !vanadium 1 or 2
real(dp), allocatable, dimension(:,:), intent(inout) :: grid2
real(dp), allocatable, dimension(:,:), intent(out) :: combination1
integer, intent(inout) :: c22, m22
integer(kind=16) :: n_combs2, xx, pp, h
integer, allocatable, dimension(:) :: acombination, past_combs2, previous_runs2
real(dp), allocatable, dimension(:,:) :: coords22
integer :: i, x, y, a, io, n_combs, r, random_comb2
real(dp), dimension(1) :: random
character(len=1) :: n_run
!
!-------------------------------------------------------
!creating the molecular coordinates
!-------------------------------------------------------
!-------------------------------------------------------
!The structures are generated as the kth combination in lexicographical
!order, of the number of atoms in the molecule and the number of points
!on the grid, using the combinadic method
!--------------------------------------------------------
!
allocate ( acombination(n22), coords22(n22,3), combination1(n22,3) )
!
do i = 1, n22
   acombination(i) = i !123
end do
!
do x = 1, n22
   do y = 1, 3
      combination1(x,y) = grid2(acombination(x),y)
   end do
end do
!
call write_to_file(combination1, method1, n22, V22, c22, m22)
!
!------------------------------------------------------
!to count the number of possible combinations:
!-----------------------------------------------------
!
xx = n22
pp = n_grid2
n_combs2 = combination_x_of_p(xx,pp)
!
allocate ( past_combs2(n_combs2) )
!
do h = 1, n_combs2
   past_combs2(h) = 0
end do
!
!-----------------------------------------------------------
!to identify the combinations from previous runs:
!-------------------------------------------------------------
!
write(*,*) 'is this the first run? [Y/N]'
read(*,*) n_run
if (n_run == 'N') then
   open(unit=30, file='previous_runs.txt', status='old', action='read')
   n_combs = 0
   do
      read(30,*,iostat=io) i
      if (io /= 0) exit
      n_combs = n_combs + 1
   end do
   write(*,*) 'ncombs', n_combs
   close(30)
!
   open(unit=31, file='previous_runs.txt', status='old', action='read')
   allocate(previous_runs2(n_combs))
   do i = 1, n_combs
      read(31,*) previous_runs2(i)
   end do
   close(31)

   do i = 1, n_combs
      r = previous_runs2(i)
      past_combs2(r) = r
   end do
end if
!
!----------------------------------------------------------------
!randomly select a certain number of combinations
!----------------------------------------------------------------
!
open(unit=12, file='random_comb.txt', status='replace', action='write')
open(unit=32, file='previous_runs.txt', status='replace', action='write', &
   position="append")
!
a = 1
do while ((m22 .lt. 700) .and. (a .lt. n_combs2))
   call random_number(random)
   random_comb2 = nint(random(1) * n_combs2)
   if (random_comb2 == 0) cycle
   if (random_comb2 == 1) cycle
   !
   if (random_comb2 == past_combs2(random_comb2)) cycle
   !
   call lexicographical_order (random_comb2, n_grid2, n22, acombination)
   !
   write(12,*) a, random_comb2, '- combination:', acombination
   !
   do x = 1, n22
      do y = 1, 3
         coords22(x,y) = grid2(acombination(x),y)
      end do
   end do
   !
   call write_to_file (coords22, method1, n22, V22, c22, m22)
   !
   past_combs2(random_comb2) = random_comb2
   write(32,*) random_comb2
   a = a + 1
end do
close(12)
close(32)
!
deallocate(acombination, past_combs2, coords22)
deallocate(grid2)
close(9)
!
end subroutine grid_to_molecule_large
!
!-----------------------------------------------------------------
!Subroutine to write up structures
!-----------------------------------------------------------------
!
subroutine write_to_file (coords10, method2, n10, V10, c10, m10)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:,:), intent(inout) :: coords10
real(dp), allocatable, dimension(:,:) :: test_coords, flip_coords
character(len=17), intent(in) :: method2
integer, intent(in) :: n10
real(dp), allocatable, dimension(:) :: mass10
logical, intent(in) :: V10
integer, intent(inout) :: c10, m10
integer :: i, j, k, num
character(len=1) :: logic1, logic2
character(len=3) :: file1
character(len=8) :: file11
real(dp) :: coss, sinn
real(dp), dimension(3,3) :: Rzz
!
call test1(coords10, n10, logic1)
write(*,*)
write(*,*) 'test1'
write(*,*) logic1
write(*,*)
if (logic1 == 'Y') then
   call mass_array(n10, mass10)
   call center_and_main_inertia_vector (mass10, n10, coords10)
   call test2 (mass10, coords10, n10, c10, logic2)
   if (logic2 == 'Y') then
      !
      !rotate molecule by 90 degrees around the z-axis
      !in order to interchange the y- and x-axes.
      !
      allocate(test_coords(n10,3))
      coss = 0.0
      sinn = 1.0
      call z_rotation_matrix (coss, sinn, Rzz)
      test_coords = matmul(coords10, Rzz)
      call test2 (mass10, test_coords, n10, c10, logic2)
      if (logic2 == 'Y') then
         allocate(flip_coords(n10,3))
         !
         !flip the coordinates in coords10 by the
         !x-, y- and z-axes:
         !
         do j = 1, 3
            do i = 1, n10
               do k = 1, 3
               flip_coords(i,k) = coords10(i,k)
               end do
            end do
            do i = 1, n10
               flip_coords(i,j) = -coords10(i,j)
            end do
            call test2 (mass10, flip_coords, n10, c10, logic2)
            if (logic2 == 'N') exit
         end do
         if (logic2 == 'Y') then
            !
            !flip the coordinates in test_coords
            !by the x-, y- and z- axes.
            !
            do j = 1, 3
               do i = 1, n10
                  do k = 1, 3
                  flip_coords(i,k) = test_coords(i,k)
                  end do
               end do
               do i = 1, n10
                  flip_coords(i,j) = -test_coords(i,j)
               end do
               call test2 (mass10, flip_coords, n10, c10, logic2)
               if (logic2 == 'N') exit
            end do
         end if
      deallocate (flip_coords)
      end if
      !
      deallocate (test_coords)
   end if
   !
   write(*,*)
   write(*,*) 'test2'
   write(*,*) logic2
   write(*,*)
   !
   !write out the structure:
   !
   if (logic2 == 'Y') then
      write(*,*)
      write(*,*) 'c10', c10
      write(*,*)
      !
      !For test:
      !
      write(file1, "(I3)") c10
      num = 1000 + c10
      write(file11, "(I4,A4)") num, '.xyz'
      open(unit=c10, file=file1, status='new', action='write')
      do i = 1, n10
         write(c10,*) mass10(i), (coords10(i,j), j = 1, 3)
      end do
      close(c10)
      !
      !For me:
      !
      open(unit=num, file=file11, status='new', action='write')
      write(num,'(I2)') n10
      write(num,'(A17)') method2
      do i = 1, n10
         write(num,'(A1,A1,A17,3F11.7)') ' ', 'C', '                ', (coords10(i,j), j = 1, 3)
      end do
      close(num)
      !
      c10 = c10 + 1
      !
      call asign_labels(coords10, method2, V10, m10, n10)
   end if
   deallocate(mass10)
end if
!
end subroutine write_to_file
!
!-------------------------------------------------------
!make xyz structures with labels:
!-------------------------------------------------------
!
subroutine asign_labels (coords7, method3, vanadium2, m7, n7)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:,:), intent(inout) :: coords7
character(len=17), intent(in) :: method3
real(dp), allocatable, dimension(:,:) :: random_array
logical, intent(in) ::  vanadium2
integer, intent(in) :: n7 !number of atoms
integer, intent(inout) :: m7 !structure in to print
character(len=1), allocatable, dimension(:) :: labels
character(len=7) :: file7
logical, allocatable, dimension(:) :: SEA_T_F
integer :: i, j, l, p
!
call SEA (coords7, n7, SEA_T_F)
!
allocate ( random_array(n7,3) )
!
call random_number(random_array)
do i = 1, n7
   do j = 1, 3
      coords7(i,j) = coords7(i,j) + (random_array(i,j)-0.5)*0.2
   end do
end do
deallocate(random_array)
!
allocate( labels(n7) )
!
if (vanadium2 .eqv. .true.) then
   do i = 1, n7 - 1
      do l = i + 1, n7
         if (SEA_T_F(i) .eqv. .false.) then
            if (SEA_T_F(l) .eqv. .false.) then
               do j = 1, n7
                  labels(j) = 'B'
               end do
               labels(i) = 'V'
               labels(l) = 'V'
               !
               write(file7, "(I3,A4)") m7, ".gjf"
               open (unit=m7, file=file7, status='new', action='write')
               write(m7,'(I2)') n7
               write(m7,'(A17)') method3
               do p = 1, n7
                  write(m7,'(A1,A1,A17,3F11.7)') ' ', labels(p), '                     ', (coords7(p,j), j=1,3)
               end do
               close(m7)
               !
               m7 = m7 + 1
            end if
         end if
      end do
   end do
   !
else if (vanadium2 .eqv. .false.) then
   do i = 1, n7
      if (SEA_T_F(i) .eqv. .false.) then
         do j = 1, n7
            labels(j) = 'B'
         end do
         labels(i) = 'V'
         !
         write(file7, '(I3,A4)') m7, ".xyz"
         open (unit=m7, file=file7, status='new', action='write')
         write(m7,'(I2)') n7
         write(m7,'(A17)') method3
         do p = 1, n7
            write(m7,'(A1,A1,A17,3F11.7)') ' ', labels(p), '                 ', (coords7(p,j), j=1,3)
         end do
         close(m7)
         !
         m7 = m7 + 1
      end if
   end do
end if
!
deallocate (labels)
!
end subroutine asign_labels
!
!--------------------------------------------------------
!generate random 3d structures:
!--------------------------------------------------------
!
subroutine generate_random3d (n1, d1, coordinates4)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
integer, intent(in) :: n1 !number of atoms
real(dp), intent(in) :: d1 !average size of the molecule
real(dp), allocatable, dimension(:,:), intent(out) :: coordinates4
integer :: i, j
!
allocate( coordinates4(n1,3) )
!
call random_number(coordinates4)
!
do i = 1, n1
  do j = 1, 3
    coordinates4(i,j) = coordinates4(i,j) * d1
  end do
end do
!
end subroutine generate_random3d
!
!-------------------------------------------------------
!generate 2d structures:
!-------------------------------------------------------
!
subroutine generate_random2d (n2, d2, coordinates5)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
integer, intent(in) :: n2
real(dp), intent(in) :: d2
real(dp), allocatable, dimension (:,:), intent(out) :: coordinates5
integer :: i, j
!
allocate( coordinates5(n2,3) )
!
call random_number(coordinates5)
!
do i = 1, n2
  do j = 1, 2
    coordinates5(i,j) = coordinates5(i,j) * d2
  end do
end do
!
do i = 1, n2
  coordinates5(i,3) = 0.0
end do
!
end subroutine generate_random2d
!
!-------------------------------------------------------
!subroutine for coordinate walking in 2d
!-------------------------------------------------------
!
subroutine coordinate_walk (first_coords, method15, D3, V15, n15, &
      c15, m15)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:,:), intent(in) :: first_coords
character(len=17), intent(in) :: method15
character(len=1), intent(in) :: D3
integer, intent(in) :: n15
logical, intent(in) :: V15
integer, intent(inout) :: c15, m15
real(dp), allocatable, dimension(:,:) :: coords15, test
integer :: i, j, m_end, dim_walk, m14, x, y, k, m13, m17
real(dp) :: move
character(len=1) :: end_cycle
!
allocate( coords15(n15,3), test(n15,3) )
!
do i = 1, n15
   do j = 1, 3
      coords15(i,j) = first_coords(i,j)
   end do
end do
!
if (D3 == 'N') then
   m_end = m15 + 100
   dim_walk = 2
else if (D3 == 'Y') then
   m_end = m15 + 200
   dim_walk = 3
else
   write(25,*) 'something is wrong'
   stop
end if
!
write(*,*) 'D3', D3, 'm_end', m_end, 'dim_walk', dim_walk
!
i = 1 ! used to loop over the atoms.
k = 1
!
!write(*,*) 'by how much should the value for each coordinate change?'
!read(*,*) move
!
move = 0.05
!
m13 = m15
m17 = m15
!
do while (m15 .lt. m_end)
   write(25,*)
   write(25,*) 'coordinate walk'
   write(25,*) 'cycle', k, 'walk', i
   write(25,*) 'change of coordinates', move
   write(25,*)
   do x = 1, n15
      do y = 1, 3
         test(x,y) = coords15(x,y)
      end do
   end do
      m14 = m15
      do j = 1, dim_walk
         write(25,*)'--------------------------------------------'
         write(25,*)
         write(25,*) i, j, 'test(i,j)-before', test(i,j)
         test(i,j) = random_walk(test(i,j), move)
         write(25,*) 'test(i,j)-after', test(i,j)
      end do
         !
         call write_to_file (test, method15, n15, V15, c15, m15)
         !
         if (m15 .gt. m14) then
            write(25,*) 'm15', m15
            write(25,*) 'successful walk'
            do x = 1, n15
               do y = 1, 3
                  coords15(x,y) = test(x,y)
               end do
            end do
            !
         else
            write(*,*) 'bad walk'
         end if
      if (i == n15) then
         i = 1
         k = k + 1
         !
!         write(*,*) 'structures printed at the start of the subroutine:'
!         write(*,*) m17
!         write(*,*) 'structures printed up to the start of the cycle:'
!         write(*,*) m13
!         write(*,*) 'structures printed now:'
!         write(*,*) m15
!         write(*,*) 'exit? [Y/N]'
!         read(*,*) end_cycle
         end_cycle = 'N'
         if (end_cycle == 'Y') exit
        ! write(*,*) 'new value for the change of coordinates?'
        ! read(*,*) move
        ! m13 = m15
      else
         i = i + 1
      end if
end do
!

deallocate(coords15, test)

end subroutine coordinate_walk
!
!------------------------------------------------
!subroutine to initialize the mass=1 array, used for comparisons
!-------------------------------------------------
!
subroutine mass_array(n12, mass12)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
integer, intent(in) :: n12
real(dp), allocatable, dimension(:), intent(out) :: mass12
integer :: i
!
allocate(mass12(n12))
do i = 1, n12
   mass12(i) = 1.0D0
end do
!
end subroutine mass_array
!
end module generate_structures


MODULE  m_fergwt
  USE m_juDFT
  !****************************************************************
  !     determines the fermi energy and weights for the k-space
  !     integration using gaussing-smearing method.
  !                                               c.l.fu
  !*****************************************************************
CONTAINS
  SUBROUTINE fergwt(kpts,input,fmpi, ne,eig, ef,w_iks,seigv)

    USE m_constants
    USE m_types
    IMPLICIT NONE

    TYPE(t_mpi),INTENT(IN)       :: fmpi
    TYPE(t_input),INTENT(IN)     :: input
    TYPE(t_kpts),INTENT(IN)      :: kpts
    REAL,        INTENT(INOUT)   :: ef,seigv
    REAL,INTENT(INOUT)           :: w_iks(:,:,:)
    !     ..
    !     ..
    !     .. Array Arguments ..
    INTEGER, INTENT (IN) :: ne(:,:)    !(kpts%nkpt,dimension%jspd)
    REAL,    INTENT (IN) :: eig(:,:,:) !input%neig,kpts%nkpt,dimension%jspd)
    !     ..
    !     .. Local Scalars ..
    REAL chmom,de,ef0,ef1,elow,en,eps,eup,fac,fact1,s,s0,s1,s2,&
         workf,wt,wtk,zcdiff,zero,seigv1
    INTEGER i,ifl,it,jspin,k,nbnd
    !     ..
    !     .. External Functions ..
    REAL  erf
    !     ..
    !     .. Data statements ..
    DATA zero/0.e0/,eps/1.e-5/,eup/3.0e0/,elow/-3.0e0/
    !     ..
    fact1 = input%tkb/SQRT(pi_const)
    !     ---> determines ef
    ifl = 0
    conv_loop:DO WHILE (.TRUE.)
       DO  it = 1,50
          s = 0.
          DO  jspin = 1,input%jspins
             DO  k = 1,kpts%nkpt
                wtk = kpts%wtkpt(k)
                nbnd = ne(k,jspin)
                DO  i = 1,nbnd
                   en = eig(i,k,jspin)
                   de = (en-ef)/input%tkb
                   wt = 2.0
                   IF (de.GT.eup) wt = 0.0
                   IF (de.GE.elow .AND. de.LE.eup) THEN
                      IF (de.LT.zero) THEN
                         wt = 1. + ERF(-de)
                      ELSE
                         wt = 1. - ERF(de)
                      END IF
                   END IF
                   s = s + wt*wtk
                   w_iks(i,k,jspin) = wt/2.
                ENDDO
             ENDDO
          ENDDO
          s = s/REAL(input%jspins)
          zcdiff = input%zelec - s
          IF (ABS(zcdiff).LT.eps) EXIT conv_loop
          IF (ifl.EQ.0) THEN
             ifl = 1
             ef0 = ef
             ef = ef + 0.003
             s0 = s
          ELSE
             fac = (s0-s)/ (input%zelec-s)
             IF (ABS(fac).LT.1.0e-1) THEN
                ef0 = ef
                s0 = s
                IF (zcdiff.GE.zero) THEN
                   ef = ef + 0.003
                ELSE
                   ef = ef - 0.003
                END IF
             ELSE
                ef1 = ef
                ef = ef + (ef0-ef)/fac
                ef0 = ef1
                s0 = s
             END IF
          END IF
       ENDDO
       eps = 1.25*eps
       IF ( fmpi%irank == 0 ) WRITE (oUnit,FMT=8000) eps
8000   FORMAT (10x,'warning: eps has been increased to',e12.5)
    ENDDO conv_loop
    workf = -hartree_to_ev_const*ef
    IF ( fmpi%irank == 0 ) THEN
       WRITE (oUnit,FMT=8010) ef,workf,s
    END IF
8010 FORMAT (/,10x,'fermi energy=',f10.5,' har',3x,'work function=',&
               f10.5,' ev',/,10x,'number of valence electrons=',f10.5)
    IF (ABS(zcdiff).GT.5.0e-4) THEN
       CALL juDFT_error('Fermi-level determination did not converge',&
                        hint ="change temperature or set input = F", calledby ="fergwt")
    ENDIF
    DO  jspin = 1,input%jspins
       IF ( fmpi%irank == 0 ) WRITE (oUnit,FMT=8020) jspin
8020   FORMAT (/,/,5x,'band-weighting factor for spin=',i5)
       DO  k = 1,kpts%nkpt
          nbnd = ne(k,jspin)
          IF ( fmpi%irank == 0 ) WRITE (oUnit,FMT=8030) k
8030      FORMAT (/,5x,'k-point=',i5,/)
          w_iks(:,k,jspin) = kpts%wtkpt(k)*w_iks(:,k,jspin)
          IF ( fmpi%irank == 0) THEN
             WRITE (oUnit,FMT=8040) (w_iks(i,k,jspin),i=1,nbnd)
          END IF
8040      FORMAT (5x,16f6.3)
       ENDDO
    ENDDO
    s1 = 0.
    s2 = 0.
    DO  jspin = 1,input%jspins
       s = 0.
       DO  k = 1,kpts%nkpt
          DO  i = 1,ne(k,jspin)
             s = s + w_iks(i,k,jspin)
             seigv = seigv + w_iks(i,k,jspin)*eig(i,k,jspin)
             en = eig(i,k,jspin)
             de = (en-ef)/input%tkb
             !     ---> correction term
             IF (ABS(de).LT.3.) THEN
                de = de*de
                s2 = s2 + EXP(-de)*kpts%wtkpt(k)
             END IF
          ENDDO
       ENDDO
       s1 = s1 + s
    ENDDO
    seigv = (2/input%jspins)*seigv
    seigv1 = (1/input%jspins)*fact1*s2
    chmom = s1 - input%jspins*s
    IF ( fmpi%irank == 0 ) THEN
       WRITE (oUnit,FMT=8050) seigv - seigv1,s1,chmom
    END IF
8050 FORMAT (/,10x,'sum of eigenvalues-correction=',f12.5,/,10x,&
          'sum of weight                =',f12.5,/,10x,&
          'total moment                 =',f12.5,/)

  END SUBROUTINE fergwt
END MODULE m_fergwt


program kidou_ex2_7a
  !天体と軌道の力学(p.56)[例2.7a]
  !iとu_iの値を出力する
  implicit none
  integer::n
  real(8)::pi,e,l,u

  pi=4.0d0*atan(1.0d0)
  e=0.249
  l=(12.14/180)*pi

  u=l
  n=0
  write(*,*) n,(u/pi)*180
  do n=1,9
     u=l+e*sin(u)
     write(*,*) n,(u/pi)*180
  end do

end program kidou_ex2_7a


      SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK driver routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  DGESV computes the solution to a real system of linear equations
*     A * X = B,
*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*
*  The LU decomposition with partial pivoting and row interchanges is
*  used to factor A as
*     A = P * L * U,
*  where P is a permutation matrix, L is unit lower triangular, and U is
*  upper triangular.  The factored form of A is then used to solve the
*  system of equations A * X = B.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of linear equations, i.e., the order of the
*          matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the N-by-N coefficient matrix A.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (output) INTEGER array, dimension (N)
*          The pivot indices that define the permutation matrix P;
*          row i of the matrix was interchanged with row IPIV(i).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          On entry, the N-by-NRHS matrix of right hand side matrix B.
*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
*                has been completed, but the factor U is exactly
*                singular, so the solution could not be computed.
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           DGETRF, DGETRS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGESV ', -INFO )
         RETURN
      END IF
*
*     Compute the LU factorization of A.
*
      CALL DGETRF( N, N, A, LDA, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
     $                INFO )
      END IF
      RETURN
*
*     End of DGESV
*
      END
      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DGETF2 computes an LU factorization of a general m-by-n matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This is the right-looking Level 2 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the m by n matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
*               has been completed, but the factor U is exactly
*               singular, and division by zero will occur if it is used
*               to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   SFMIN
      INTEGER            I, J, JP
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      INTEGER            IDAMAX
      EXTERNAL           DLAMCH, IDAMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF

      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETF2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Compute machine safe minimum
*

      SFMIN = DLAMCH('S')

      DO 10 J = 1, MIN( M, N )
*
*        Find pivot and test for singularity.
*
         JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
*
*           Apply the interchange to columns 1:N.
*
            IF( JP.NE.J )
     $         CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
*
*           Compute elements J+1:M of J-th column.
*
            IF( J.LT.M ) THEN
               IF( ABS(A( J, J )) .GE. SFMIN ) THEN
                  CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
               ELSE
                 DO 20 I = 1, M-J
                    A( J+I, J ) = A( J+I, J ) / A( J, J )
   20            CONTINUE
               END IF
            END IF
*
         ELSE IF( INFO.EQ.0 ) THEN
*
            INFO = J
         END IF
*
         IF( J.LT.MIN( M, N ) ) THEN
*
*           Update trailing submatrix.
*
            CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
     $                 A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
*
*     End of DGETF2
*
      END
      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DGETRF computes an LU factorization of a general M-by-N matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This is the right-looking Level 3 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
*                has been completed, but the factor U is exactly
*                singular, and division by zero will occur if it is used
*                to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DGETF2, DLASWP, DTRSM, XERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Determine the block size for this environment.
*
      NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
*        Use unblocked code.
*
         CALL DGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
*
*        Use blocked code.
*
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
*
*           Factor diagonal and subdiagonal blocks and test for exact
*           singularity.
*
            CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
*
*           Adjust INFO and the pivot indices.
*
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )
     $         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
*
*           Apply interchanges to columns 1:J-1.
*
            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
            IF( J+JB.LE.N ) THEN
*
*              Apply interchanges to columns J+JB:N.
*
               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
     $                      IPIV, 1 )
*
*              Compute block row of U.
*
               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
     $                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
     $                     LDA )
               IF( J+JB.LE.M ) THEN
*
*                 Update trailing submatrix.
*
                  CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1,
     $                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
     $                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
     $                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
*
*     End of DGETRF
*
      END
      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK routine (version 3.3.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*  -- April 2011                                                      --
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  DGETRS solves a system of linear equations
*     A * X = B  or  A**T * X = B
*  with a general N-by-N matrix A using the LU factorization computed
*  by DGETRF.
*
*  Arguments
*  =========
*
*  TRANS   (input) CHARACTER*1
*          Specifies the form of the system of equations:
*          = 'N':  A * X = B  (No transpose)
*          = 'T':  A**T* X = B  (Transpose)
*          = 'C':  A**T* X = B  (Conjugate transpose = Transpose)
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*          The factors L and U from the factorization A = P*L*U
*          as computed by DGETRF.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (input) INTEGER array, dimension (N)
*          The pivot indices from DGETRF; for 1<=i<=N, row i of the
*          matrix was interchanged with row IPIV(i).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          On entry, the right hand side matrix B.
*          On exit, the solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOTRAN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLASWP, DTRSM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
      IF( NOTRAN ) THEN
*
*        Solve A * X = B.
*
*        Apply row interchanges to the right hand sides.
*
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
*
*        Solve L*X = B, overwriting B with X.
*
         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
*
*        Solve U*X = B, overwriting B with X.
*
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
     $               NRHS, ONE, A, LDA, B, LDB )
      ELSE
*
*        Solve A**T * X = B.
*
*        Solve U**T *X = B, overwriting B with X.
*
         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
*
*        Solve L**T *X = B, overwriting B with X.
*
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
     $               A, LDA, B, LDB )
*
*        Apply row interchanges to the solution vectors.
*
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
*
      RETURN
*
*     End of DGETRS
*
      END
      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DLASWP performs a series of row interchanges on the matrix A.
*  One row interchange is initiated for each of rows K1 through K2 of A.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the matrix of column dimension N to which the row
*          interchanges will be applied.
*          On exit, the permuted matrix.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.
*
*  K1      (input) INTEGER
*          The first element of IPIV for which a row interchange will
*          be done.
*
*  K2      (input) INTEGER
*          The last element of IPIV for which a row interchange will
*          be done.
*
*  IPIV    (input) INTEGER array, dimension (K2*abs(INCX))
*          The vector of pivot indices.  Only the elements in positions
*          K1 through K2 of IPIV are accessed.
*          IPIV(K) = L implies rows K and L are to be interchanged.
*
*  INCX    (input) INTEGER
*          The increment between successive values of IPIV.  If IPIV
*          is negative, the pivots are applied in reverse order.
*
*  Further Details
*  ===============
*
*  Modified by
*   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
      DOUBLE PRECISION   TEMP
*     ..
*     .. Executable Statements ..
*
*     Interchange row I with row IPIV(I) for each of rows K1 through K2.
*
      IF( INCX.GT.0 ) THEN
         IX0 = K1
         I1 = K1
         I2 = K2
         INC = 1
      ELSE IF( INCX.LT.0 ) THEN
         IX0 = 1 + ( 1-K2 )*INCX
         I1 = K2
         I2 = K1
         INC = -1
      ELSE
         RETURN
      END IF
*
      N32 = ( N / 32 )*32
      IF( N32.NE.0 ) THEN
         DO 30 J = 1, N32, 32
            IX = IX0
            DO 20 I = I1, I2, INC
               IP = IPIV( IX )
               IF( IP.NE.I ) THEN
                  DO 10 K = J, J + 31
                     TEMP = A( I, K )
                     A( I, K ) = A( IP, K )
                     A( IP, K ) = TEMP
   10             CONTINUE
               END IF
               IX = IX + INCX
   20       CONTINUE
   30    CONTINUE
      END IF
      IF( N32.NE.N ) THEN
         N32 = N32 + 1
         IX = IX0
         DO 50 I = I1, I2, INC
            IP = IPIV( IX )
            IF( IP.NE.I ) THEN
               DO 40 K = N32, N
                  TEMP = A( I, K )
                  A( I, K ) = A( IP, K )
                  A( IP, K ) = TEMP
   40          CONTINUE
            END IF
            IX = IX + INCX
   50    CONTINUE
      END IF
*
      RETURN
*
*     End of DLASWP
*
      END
*> \brief \b DLAMCH
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*      DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLAMCH determines double precision machine parameters.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] CMACH
*> \verbatim
*>          Specifies the value to be returned by DLAMCH:
*>          = 'E' or 'e',   DLAMCH := eps
*>          = 'S' or 's ,   DLAMCH := sfmin
*>          = 'B' or 'b',   DLAMCH := base
*>          = 'P' or 'p',   DLAMCH := eps*base
*>          = 'N' or 'n',   DLAMCH := t
*>          = 'R' or 'r',   DLAMCH := rnd
*>          = 'M' or 'm',   DLAMCH := emin
*>          = 'U' or 'u',   DLAMCH := rmin
*>          = 'L' or 'l',   DLAMCH := emax
*>          = 'O' or 'o',   DLAMCH := rmax
*>          where
*>          eps   = relative machine precision
*>          sfmin = safe minimum, such that 1/sfmin does not overflow
*>          base  = base of the machine
*>          prec  = eps*base
*>          t     = number of (base) digits in the mantissa
*>          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
*>          emin  = minimum exponent before (gradual) underflow
*>          rmin  = underflow threshold - base**(emin-1)
*>          emax  = largest exponent before overflow
*>          rmax  = overflow threshold  - (base**emax)*(1-eps)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          CMACH
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   RND, EPS, SFMIN, SMALL, RMACH
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DIGITS, EPSILON, HUGE, MAXEXPONENT,
     $                   MINEXPONENT, RADIX, TINY
*     ..
*     .. Executable Statements ..
*
*
*     Assume rounding, not chopping. Always.
*
      RND = ONE
*
      IF( ONE.EQ.RND ) THEN
         EPS = EPSILON(ZERO) * 0.5
      ELSE
         EPS = EPSILON(ZERO)
      END IF
*
      IF( LSAME( CMACH, 'E' ) ) THEN
         RMACH = EPS
      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
         SFMIN = TINY(ZERO)
         SMALL = ONE / HUGE(ZERO)
         IF( SMALL.GE.SFMIN ) THEN
*
*           Use SMALL plus a bit, to avoid the possibility of rounding
*           causing overflow when computing  1/sfmin.
*
            SFMIN = SMALL*( ONE+EPS )
         END IF
         RMACH = SFMIN
      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
         RMACH = RADIX(ZERO)
      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
         RMACH = EPS * RADIX(ZERO)
      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
         RMACH = DIGITS(ZERO)
      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
         RMACH = RND
      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
         RMACH = MINEXPONENT(ZERO)
      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
         RMACH = tiny(zero)
      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
         RMACH = MAXEXPONENT(ZERO)
      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
         RMACH = HUGE(ZERO)
      ELSE
         RMACH = ZERO
      END IF
*
      DLAMCH = RMACH
      RETURN
*
*     End of DLAMCH
*
      END
************************************************************************
*> \brief \b DLAMC3
*> \details
*> \b Purpose:
*> \verbatim
*> DLAMC3  is intended to force  A  and  B  to be stored prior to doing
*> the addition of  A  and  B ,  for use in situations where optimizers
*> might hold one of these in a register.
*> \endverbatim
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
*> \date November 2011
*> \ingroup auxOTHERauxiliary
*>
*> \param[in] A
*> \verbatim
*>          A is a DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is a DOUBLE PRECISION
*>          The values A and B.
*> \endverbatim
*>
      DOUBLE PRECISION FUNCTION DLAMC3( A, B )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2010
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B
*     ..
* =====================================================================
*
*     .. Executable Statements ..
*
      DLAMC3 = A + B
*
      RETURN
*
*     End of DLAMC3
*
      END
*
************************************************************************
*> \brief \b IEEECK
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download IEEECK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ieeeck.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ieeeck.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ieeeck.f">
*> [TXT]</a>
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )
*
*       .. Scalar Arguments ..
*       INTEGER            ISPEC
*       REAL               ONE, ZERO
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> IEEECK is called from the ILAENV to verify that Infinity and
*> possibly NaN arithmetic is safe (i.e. will not trap).
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] ISPEC
*> \verbatim
*>          ISPEC is INTEGER
*>          Specifies whether to test just for inifinity arithmetic
*>          or whether to test for infinity and NaN arithmetic.
*>          = 0: Verify infinity arithmetic only.
*>          = 1: Verify infinity and NaN arithmetic.
*> \endverbatim
*>
*> \param[in] ZERO
*> \verbatim
*>          ZERO is REAL
*>          Must contain the value 0.0
*>          This is passed to prevent the compiler from optimizing
*>          away this code.
*> \endverbatim
*>
*> \param[in] ONE
*> \verbatim
*>          ONE is REAL
*>          Must contain the value 1.0
*>          This is passed to prevent the compiler from optimizing
*>          away this code.
*>
*>  RETURN VALUE:  INTEGER
*>          = 0:  Arithmetic failed to produce the correct answers
*>          = 1:  Arithmetic produced the correct answers
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            ISPEC
      REAL               ONE, ZERO
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
     $                   NEGZRO, NEWZRO, POSINF
*     ..
*     .. Executable Statements ..
      IEEECK = 1
*
      POSINF = ONE / ZERO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGINF = -ONE / ZERO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGZRO = ONE / ( NEGINF+ONE )
      IF( NEGZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGINF = ONE / NEGZRO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEWZRO = NEGZRO + ZERO
      IF( NEWZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      POSINF = ONE / NEWZRO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGINF = NEGINF*POSINF
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      POSINF = POSINF*POSINF
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
*
*
*
*
*     Return if we were only asked to check infinity arithmetic
*
      IF( ISPEC.EQ.0 )
     $   RETURN
*
      NAN1 = POSINF + NEGINF
*
      NAN2 = POSINF / NEGINF
*
      NAN3 = POSINF / POSINF
*
      NAN4 = POSINF*ZERO
*
      NAN5 = NEGINF*NEGZRO
*
      NAN6 = NAN5*ZERO
*
      IF( NAN1.EQ.NAN1 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN2.EQ.NAN2 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN3.EQ.NAN3 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN4.EQ.NAN4 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN5.EQ.NAN5 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN6.EQ.NAN6 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      RETURN
      END
*> \brief \b ILAENV
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILAENV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilaenv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilaenv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilaenv.f">
*> [TXT]</a>
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
*       .. Scalar Arguments ..
*       CHARACTER*( * )    NAME, OPTS
*       INTEGER            ISPEC, N1, N2, N3, N4
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ILAENV is called from the LAPACK routines to choose problem-dependent
*> parameters for the local environment.  See ISPEC for a description of
*> the parameters.
*>
*> ILAENV returns an INTEGER
*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
*> if ILAENV < 0:  if ILAENV = -k, the k-th argument had an illegal value.
*>
*> This version provides a set of parameters which should give good,
*> but not optimal, performance on many of the currently available
*> computers.  Users are encouraged to modify this subroutine to set
*> the tuning parameters for their particular machine using the option
*> and problem size information in the arguments.
*>
*> This routine will not function correctly if it is converted to all
*> lower case.  Converting it to all upper case is allowed.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] ISPEC
*> \verbatim
*>          ISPEC is INTEGER
*>          Specifies the parameter to be returned as the value of
*>          ILAENV.
*>          = 1: the optimal blocksize; if this value is 1, an unblocked
*>               algorithm will give the best performance.
*>          = 2: the minimum block size for which the block routine
*>               should be used; if the usable block size is less than
*>               this value, an unblocked routine should be used.
*>          = 3: the crossover point (in a block routine, for N less
*>               than this value, an unblocked routine should be used)
*>          = 4: the number of shifts, used in the nonsymmetric
*>               eigenvalue routines (DEPRECATED)
*>          = 5: the minimum column dimension for blocking to be used;
*>               rectangular blocks must have dimension at least k by m,
*>               where k is given by ILAENV(2,...) and m by ILAENV(5,...)
*>          = 6: the crossover point for the SVD (when reducing an m by n
*>               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
*>               this value, a QR factorization is used first to reduce
*>               the matrix to a triangular form.)
*>          = 7: the number of processors
*>          = 8: the crossover point for the multishift QR method
*>               for nonsymmetric eigenvalue problems (DEPRECATED)
*>          = 9: maximum size of the subproblems at the bottom of the
*>               computation tree in the divide-and-conquer algorithm
*>               (used by xGELSD and xGESDD)
*>          =10: ieee NaN arithmetic can be trusted not to trap
*>          =11: infinity arithmetic can be trusted not to trap
*>          12 <= ISPEC <= 16:
*>               xHSEQR or one of its subroutines,
*>               see IPARMQ for detailed explanation
*> \endverbatim
*>
*> \param[in] NAME
*> \verbatim
*>          NAME is CHARACTER*(*)
*>          The name of the calling subroutine, in either upper case or
*>          lower case.
*> \endverbatim
*>
*> \param[in] OPTS
*> \verbatim
*>          OPTS is CHARACTER*(*)
*>          The character options to the subroutine NAME, concatenated
*>          into a single character string.  For example, UPLO = 'U',
*>          TRANS = 'T', and DIAG = 'N' for a triangular routine would
*>          be specified as OPTS = 'UTN'.
*> \endverbatim
*>
*> \param[in] N1
*> \verbatim
*>          N1 is INTEGER
*> \endverbatim
*>
*> \param[in] N2
*> \verbatim
*>          N2 is INTEGER
*> \endverbatim
*>
*> \param[in] N3
*> \verbatim
*>          N3 is INTEGER
*> \endverbatim
*>
*> \param[in] N4
*> \verbatim
*>          N4 is INTEGER
*>          Problem dimensions for the subroutine NAME; these may not all
*>          be required.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The following conventions have been used when calling ILAENV from the
*>  LAPACK routines:
*>  1)  OPTS is a concatenation of all of the character options to
*>      subroutine NAME, in the same order that they appear in the
*>      argument list for NAME, even if they are not used in determining
*>      the value of the parameter specified by ISPEC.
*>  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
*>      that they appear in the argument list for NAME.  N1 is used
*>      first, N2 second, and so on, and unused problem dimensions are
*>      passed a value of -1.
*>  3)  The parameter value returned by ILAENV is checked for validity in
*>      the calling subroutine.  For example, ILAENV is used to retrieve
*>      the optimal blocksize for STRTRI as follows:
*>
*>      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
*>      IF( NB.LE.1 ) NB = MAX( 1, N )
*> \endverbatim
*>
*  =====================================================================
*> \brief \b IPARMQ
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download IPARMQ + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/iparmq.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/iparmq.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/iparmq.f">
*> [TXT]</a>
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
*
*       .. Scalar Arguments ..
*       INTEGER            IHI, ILO, ISPEC, LWORK, N
*       CHARACTER          NAME*( * ), OPTS*( * )
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>      This program sets problem and machine dependent parameters
*>      useful for xHSEQR and its subroutines. It is called whenever
*>      ILAENV is called with 12 <= ISPEC <= 16
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] ISPEC
*> \verbatim
*>          ISPEC is integer scalar
*>              ISPEC specifies which tunable parameter IPARMQ should
*>              return.
*>
*>              ISPEC=12: (INMIN)  Matrices of order nmin or less
*>                        are sent directly to xLAHQR, the implicit
*>                        double shift QR algorithm.  NMIN must be
*>                        at least 11.
*>
*>              ISPEC=13: (INWIN)  Size of the deflation window.
*>                        This is best set greater than or equal to
*>                        the number of simultaneous shifts NS.
*>                        Larger matrices benefit from larger deflation
*>                        windows.
*>
*>              ISPEC=14: (INIBL) Determines when to stop nibbling and
*>                        invest in an (expensive) multi-shift QR sweep.
*>                        If the aggressive early deflation subroutine
*>                        finds LD converged eigenvalues from an order
*>                        NW deflation window and LD.GT.(NW*NIBBLE)/100,
*>                        then the next QR sweep is skipped and early
*>                        deflation is applied immediately to the
*>                        remaining active diagonal block.  Setting
*>                        IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a
*>                        multi-shift QR sweep whenever early deflation
*>                        finds a converged eigenvalue.  Setting
*>                        IPARMQ(ISPEC=14) greater than or equal to 100
*>                        prevents TTQRE from skipping a multi-shift
*>                        QR sweep.
*>
*>              ISPEC=15: (NSHFTS) The number of simultaneous shifts in
*>                        a multi-shift QR iteration.
*>
*>              ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
*>                        following meanings.
*>                        0:  During the multi-shift QR sweep,
*>                            xLAQR5 does not accumulate reflections and
*>                            does not use matrix-matrix multiply to
*>                            update the far-from-diagonal matrix
*>                            entries.
*>                        1:  During the multi-shift QR sweep,
*>                            xLAQR5 and/or xLAQRaccumulates reflections and uses
*>                            matrix-matrix multiply to update the
*>                            far-from-diagonal matrix entries.
*>                        2:  During the multi-shift QR sweep.
*>                            xLAQR5 accumulates reflections and takes
*>                            advantage of 2-by-2 block structure during
*>                            matrix-matrix multiplies.
*>                        (If xTRMM is slower than xGEMM, then
*>                        IPARMQ(ISPEC=16)=1 may be more efficient than
*>                        IPARMQ(ISPEC=16)=2 despite the greater level of
*>                        arithmetic work implied by the latter choice.)
*> \endverbatim
*>
*> \param[in] NAME
*> \verbatim
*>          NAME is character string
*>               Name of the calling subroutine
*> \endverbatim
*>
*> \param[in] OPTS
*> \verbatim
*>          OPTS is character string
*>               This is a concatenation of the string arguments to
*>               TTQRE.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is integer scalar
*>               N is the order of the Hessenberg matrix H.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*>          ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*>          IHI is INTEGER
*>               It is assumed that H is already upper triangular
*>               in rows and columns 1:ILO-1 and IHI+1:N.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is integer scalar
*>               The amount of workspace available.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>       Little is known about how best to choose these parameters.
*>       It is possible to use different values of the parameters
*>       for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.
*>
*>       It is probably best to choose different parameters for
*>       different matrices and different parameters at different
*>       times during the iteration, but this has not been
*>       implemented --- yet.
*>
*>
*>       The best choices of most of the parameters depend
*>       in an ill-understood way on the relative execution
*>       rate of xLAQR3 and xLAQR5 and on the nature of each
*>       particular eigenvalue problem.  Experiment may be the
*>       only practical way to determine which choices are most
*>       effective.
*>
*>       Following is a list of default values supplied by IPARMQ.
*>       These defaults may be adjusted in order to attain better
*>       performance in any particular computational environment.
*>
*>       IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.
*>                        Default: 75. (Must be at least 11.)
*>
*>       IPARMQ(ISPEC=13) Recommended deflation window size.
*>                        This depends on ILO, IHI and NS, the
*>                        number of simultaneous shifts returned
*>                        by IPARMQ(ISPEC=15).  The default for
*>                        (IHI-ILO+1).LE.500 is NS.  The default
*>                        for (IHI-ILO+1).GT.500 is 3*NS/2.
*>
*>       IPARMQ(ISPEC=14) Nibble crossover point.  Default: 14.
*>
*>       IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
*>                        a multi-shift QR iteration.
*>
*>                        If IHI-ILO+1 is ...
*>
*>                        greater than      ...but less    ... the
*>                        or equal to ...      than        default is
*>
*>                                0               30       NS =   2+
*>                               30               60       NS =   4+
*>                               60              150       NS =  10
*>                              150              590       NS =  **
*>                              590             3000       NS =  64
*>                             3000             6000       NS = 128
*>                             6000             infinity   NS = 256
*>
*>                    (+)  By default matrices of this order are
*>                         passed to the implicit double shift routine
*>                         xLAHQR.  See IPARMQ(ISPEC=12) above.   These
*>                         values of NS are used only in case of a rare
*>                         xLAHQR failure.
*>
*>                    (**) The asterisks (**) indicate an ad-hoc
*>                         function increasing from 10 to 64.
*>
*>       IPARMQ(ISPEC=16) Select structured matrix multiply.
*>                        (See ISPEC=16 above for details.)
*>                        Default: 3.
*> \endverbatim
*>
*  =====================================================================
      INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            IHI, ILO, ISPEC, LWORK, N
      CHARACTER          NAME*( * ), OPTS*( * )
*
*  ================================================================
*     .. Parameters ..
      INTEGER            INMIN, INWIN, INIBL, ISHFTS, IACC22
      PARAMETER          ( INMIN = 12, INWIN = 13, INIBL = 14,
     $                   ISHFTS = 15, IACC22 = 16 )
      INTEGER            NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP
      PARAMETER          ( NMIN = 75, K22MIN = 14, KACMIN = 14,
     $                   NIBBLE = 14, KNWSWP = 500 )
      REAL               TWO
      PARAMETER          ( TWO = 2.0 )
*     ..
*     .. Local Scalars ..
      INTEGER            NH, NS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          LOG, MAX, MOD, NINT, REAL
*     ..
*     .. Executable Statements ..
      IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR.
     $    ( ISPEC.EQ.IACC22 ) ) THEN
*
*        ==== Set the number simultaneous shifts ====
*
         NH = IHI - ILO + 1
         NS = 2
         IF( NH.GE.30 )
     $      NS = 4
         IF( NH.GE.60 )
     $      NS = 10
         IF( NH.GE.150 )
     $      NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) )
         IF( NH.GE.590 )
     $      NS = 64
         IF( NH.GE.3000 )
     $      NS = 128
         IF( NH.GE.6000 )
     $      NS = 256
         NS = MAX( 2, NS-MOD( NS, 2 ) )
      END IF
*
      IF( ISPEC.EQ.INMIN ) THEN
*
*
*        ===== Matrices of order smaller than NMIN get sent
*        .     to xLAHQR, the classic double shift algorithm.
*        .     This must be at least 11. ====
*
         IPARMQ = NMIN
*
      ELSE IF( ISPEC.EQ.INIBL ) THEN
*
*        ==== INIBL: skip a multi-shift qr iteration and
*        .    whenever aggressive early deflation finds
*        .    at least (NIBBLE*(window size)/100) deflations. ====
*
         IPARMQ = NIBBLE
*
      ELSE IF( ISPEC.EQ.ISHFTS ) THEN
*
*        ==== NSHFTS: The number of simultaneous shifts =====
*
         IPARMQ = NS
*
      ELSE IF( ISPEC.EQ.INWIN ) THEN
*
*        ==== NW: deflation window size.  ====
*
         IF( NH.LE.KNWSWP ) THEN
            IPARMQ = NS
         ELSE
            IPARMQ = 3*NS / 2
         END IF
*
      ELSE IF( ISPEC.EQ.IACC22 ) THEN
*
*        ==== IACC22: Whether to accumulate reflections
*        .     before updating the far-from-diagonal elements
*        .     and whether to use 2-by-2 block structure while
*        .     doing it.  A small amount of work could be saved
*        .     by making this choice dependent also upon the
*        .     NH=IHI-ILO+1.
*
         IPARMQ = 0
         IF( NS.GE.KACMIN )
     $      IPARMQ = 1
         IF( NS.GE.K22MIN )
     $      IPARMQ = 2
*
      ELSE
*        ===== invalid value of ispec =====
         IPARMQ = -1
*
      END IF
*
*     ==== End of IPARMQ ====
*
      END
*> \brief \b LSAME
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*      LOGICAL FUNCTION LSAME( CA, CB )
*
*     .. Scalar Arguments ..
*      CHARACTER          CA, CB
*     ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> LSAME returns .TRUE. if CA is the same letter as CB regardless of
*> case.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] CA
*> \verbatim
*> \endverbatim
*>
*> \param[in] CB
*> \verbatim
*>          CA and CB specify the single characters to be compared.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      LOGICAL FUNCTION LSAME( CA, CB )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          CA, CB
*     ..
*
* =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
*     ..
*     .. Local Scalars ..
      INTEGER            INTA, INTB, ZCODE
*     ..
*     .. Executable Statements ..
*
*     Test if the characters are equal
*
      LSAME = CA.EQ.CB
      IF( LSAME )
     $   RETURN
*
*     Now test for equivalence if both characters are alphabetic.
*
      ZCODE = ICHAR( 'Z' )
*
*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
*     machines, on which ICHAR returns a value with bit 8 set.
*     ICHAR('A') on Prime machines returns 193 which is the same as
*     ICHAR('A') on an EBCDIC machine.
*
      INTA = ICHAR( CA )
      INTB = ICHAR( CB )
*
      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
*
*        ASCII is assumed - ZCODE is the ASCII code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
*
      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
*
*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
     $       INTA.GE.145 .AND. INTA.LE.153 .OR.
     $       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
     $       INTB.GE.145 .AND. INTB.LE.153 .OR.
     $       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
*
      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
*
*        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
*        plus 128 of either lower or upper case 'Z'.
*
         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
      END IF
      LSAME = INTA.EQ.INTB
*
*     RETURN
*
*     End of LSAME
*
      END
*> \brief \b XERBLA
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download XERBLA + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/xerbla.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/xerbla.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/xerbla.f">
*> [TXT]</a>
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE XERBLA( SRNAME, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER*(*)      SRNAME
*       INTEGER            INFO
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> XERBLA  is an error handler for the LAPACK routines.
*> It is called by an LAPACK routine if an input parameter has an
*> invalid value.  A message is printed and execution stops.
*>
*> Installers may consider modifying the STOP statement in order to
*> call system-specific exception-handling facilities.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] SRNAME
*> \verbatim
*>          SRNAME is CHARACTER*(*)
*>          The name of the routine which called XERBLA.
*> \endverbatim
*>
*> \param[in] INFO
*> \verbatim
*>          INFO is INTEGER
*>          The position of the invalid parameter in the parameter list
*>          of the calling routine.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      SUBROUTINE XERBLA( SRNAME, INFO )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER*(*)      SRNAME
      INTEGER            INFO
*     ..
*
* =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC          LEN_TRIM
*     ..
*     .. Executable Statements ..
*
      WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
*
      STOP
*
 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ',
     $      'an illegal value' )
*
*     End of XERBLA
*
      END


program swe_inf_pot_well
      use numerical_integration
      implicit none

      integer, parameter :: n_pts = 10000, n_energy = 40, max_iter_bisec = 100
      real(kind=dp), parameter :: l0 = 0.14871085d0, E0 = 938.27208816d0
      real(kind=dp) :: x(n_pts), psi(n_pts,2) ! Contains psi and psi-dot
      real(kind=dp) :: E, E_high, E_low, xmax, xmin, dx, E_list(n_energy)
      real(kind=dp) :: E_levels(5), wf_list(5,n_pts), wf_norm
      integer :: i, j, n_zero_low, n_zero_high, n_zero_mid, n_evals
      ! length and energy scales (fm and MeV)
      xmax = 12.0d0/l0
      xmin = -12.0d0/l0
      dx = (xmax-xmin)/(n_pts-1)
      x(1) = xmin
      psi(1,:) = [0.0d0, 0.01d0]
      E_list = [(i*0.001d0, i=0,n_energy-1)]

      ! Count energy levels
!      E = E_list(n_energy)
!      call rk4(x, psi, dx, n_pts, 2, swe_deriv)
!      n_evals = n_zeros(psi, n_pts)

!      write(*,*) E_list
      n_evals = 1
      do i=1,n_energy
              if (n_evals > 5) exit;
              E_low = E_list(i); E_high = E_list(i+1);

              E = E_low
              call rk4(x, psi, dx, n_pts, 2, swe_deriv)
              n_zero_low = n_zeros(psi, n_pts)

!              writ(*,*) E_low, n_zero_low
              E = E_high
              call rk4(x, psi, dx, n_pts, 2, swe_deriv)
              n_zero_high = n_zeros(psi, n_pts)

              if (n_zero_high == n_zero_low + 1) then
                      do j=1,max_iter_bisec
                        E = 0.5d0*(E_low + E_high)
                        call rk4(x, psi, dx, n_pts, 2, swe_deriv)
                        n_zero_mid = n_zeros(psi, n_pts)

                        if (n_zero_mid == n_zero_high) then
                                E_high = E
                        else
                                E_low = E
                        end if
                      end do
!                      E_levels(i) = E
                      wf_list(n_evals, :) = psi(:,1)
!                      write(*, *) E
                      E_levels(n_evals) = E
                      n_evals = n_evals + 1
              end if
              !do i=1,n_pts
              !        write(*,*) x(i), psi(i,1), psi(i,2)
              !end do
      end do
      write (*,*) E_levels*E0
      ! Normalize the wavefunctions
      do i=1, 5
         wf_norm = 0.0d0
         do j=1,n_pts
            wf_norm = wf_norm + wf_list(i, j)*wf_list(i, j)*dx
         end do
         wf_list(i, :) = wf_list(i, :)/sqrt(wf_norm)
      end do

      open(unit=25, file='wf_data.txt')
      write(25, "(A,T12,5f11.4)") 'x(t)', E_levels*E0
      do i=1, n_pts
        write(25,"(6f11.4)") x(i)*l0, wf_list(:, i)
      end do
!      write(*,*) n_zeros(psi, n_pts)
contains

        function n_zeros(wf, n_steps)
                implicit none
                integer, intent(in) :: n_steps
                real(kind=dp), dimension(n_steps), intent(in) :: wf
                integer :: i,n_zeros

                n_zeros = 0

                do i=2,n_steps
                        if (wf(i-1)*wf(i) < 0) n_zeros = n_zeros + 1
                end do

        end function n_zeros

        subroutine swe_deriv(x, psi, dpsidx)
              implicit none
              real(kind=dp) :: pot
              real(kind=dp), intent(in)  :: x, psi(2)
              real(kind=dp), dimension(2), intent(out) :: dpsidx

              ! Infinite Well
              ! pot = 0.0d0

              ! Finite Well
              ! if (abs(x) > 10.0d0/l0) then
              !         pot = 25.0d0/E0
              ! else
              !         pot = 0.0d0
              ! end if

              ! Woods-Saxon(Correct factors not yet calculated)
              pot = 25.0d0*(1.0d0-1.0d0/(1.0d0+exp(abs(2*l0*x)-10)))/E0

              dpsidx(1) = psi(2)
              dpsidx(2) = -1*(E-pot)*psi(1)

        end subroutine swe_deriv

end program swe_inf_pot_well


!==========================================================================
elemental subroutine gsw_pt_second_derivatives (sa, ct, pt_sa_sa, &
                                                pt_sa_ct, pt_ct_ct)
! =========================================================================
!
!  Calculates the following three second-order derivatives of potential
!  temperature (the regular potential temperature which has a reference
!  sea pressure of 0 dbar),
!   (1) pt_SA_SA, the second derivative with respect to Absolute Salinity
!       at constant Conservative Temperature,
!   (2) pt_SA_CT, the derivative with respect to Conservative Temperature
!       and Absolute Salinity, and
!   (3) pt_CT_CT, the second derivative with respect to Conservative
!       Temperature at constant Absolute Salinity.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!
!  pt_SA_SA  =  The second derivative of potential temperature (the
!               regular potential temperature which has reference sea
!               pressure of 0 dbar) with respect to Absolute Salinity
!               at constant Conservative Temperature.
!               pt_SA_SA has units of:                     [ K/((g/kg)^2) ]
!  pt_SA_CT  =  The derivative of potential temperature with respect
!               to Absolute Salinity and Conservative Temperature.
!               pt_SA_CT has units of:                         [ 1/(g/kg) ]
!  pt_CT_CT  =  The second derivative of potential temperature (the
!               regular one with p_ref = 0 dbar) with respect to
!               Conservative Temperature at constant SA.
!               pt_CT_CT has units of:                              [ 1/K ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_pt_first_derivatives

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct
real (r8), intent(out), optional :: pt_sa_sa, pt_sa_ct, pt_ct_ct

real (r8) :: ct_l, ct_u, pt_ct_l, pt_ct_u, pt_sa_l, pt_sa_u, sa_l, sa_u

real (r8), parameter :: dct = 1e-2_r8, dsa = 1e-3_r8

if (present(pt_sa_sa)) then

    sa_l = max(sa - dsa, 0.0_r8)
    sa_u = sa + dsa

    call gsw_pt_first_derivatives(sa_l,ct,pt_sa=pt_sa_l)
    call gsw_pt_first_derivatives(sa_u,ct,pt_sa=pt_sa_u)

    pt_sa_sa = (pt_sa_u - pt_sa_l)/(sa_u - sa_l)

end if

if (present(pt_sa_ct) .or. present(pt_ct_ct)) then

    ct_l = ct - dct
    ct_u = ct + dct

    if (present(pt_sa_ct) .and. present(pt_ct_ct)) then

        call gsw_pt_first_derivatives(sa,ct_l,pt_sa_l,pt_ct_l)
        call gsw_pt_first_derivatives(sa,ct_u,pt_sa_u,pt_ct_u)

        pt_sa_ct = (pt_sa_u - pt_sa_l)/(ct_u - ct_l)
        pt_ct_ct = (pt_ct_u - pt_ct_l)/(ct_u - ct_l)

    else if (present(pt_sa_ct) .and. .not. present(pt_ct_ct)) then

        call gsw_pt_first_derivatives(sa,ct_l,pt_sa=pt_sa_l)
        call gsw_pt_first_derivatives(sa,ct_u,pt_sa=pt_sa_u)

        pt_sa_ct = (pt_sa_u - pt_sa_l)/(ct_u - ct_l)

    else if (.not. present(pt_sa_ct) .and. present(pt_ct_ct)) then

        call gsw_pt_first_derivatives(sa,ct_l,pt_ct=pt_ct_l)
        call gsw_pt_first_derivatives(sa,ct_u,pt_ct=pt_ct_u)

        pt_ct_ct = (pt_ct_u - pt_ct_l)/(ct_u - ct_l)

    end if

end if

return
end subroutine

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