!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : det_real_matrix, inv_real_matrix, axb_real_matrix
!                : lu_real_matrix, bk_real_matrix, 
!                : improve_axb_real_matrix
!  Author(s)     : Masakuni Okamoto (August 25, 2003)
!
!
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!
!
!  The license of the code and contact address :
!  See the files, COPYRIGHT and LICENSE (or LICENSE_J.pdf)
!
!=====================================================================
   subroutine det_real_matrix(ier,n,a,det)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: n
   real(8),intent(in)  :: a(n,n)
   integer,intent(out) :: ier
   real(8),intent(out) :: det
   integer :: i, j
   real(8) :: even_odd
   integer,allocatable :: ipiv(:)
   real(8),allocatable :: a_lu(:,:)
  !++++++++++++++++++++++++++++
   allocate(a_lu(n,n),ipiv(n))
  !++++++++++++++++++++++++++++
   ier = 0
   a_lu(:,:) = 0.d0
   do i = 1,n
      do j = 1,n
         a_lu(i,j) = a(i,j)
      end do
   end do
   call lu_real_matrix(ier,n,a_lu,ipiv,even_odd)
   if (ier /= 0) then
      go to 99
   end if
   det = even_odd
   do i = 1,n
      det = det * a_lu(i,i)
   end do
99 continue
  !++++++++++++++++++++++
   deallocate(a_lu,ipiv)
  !++++++++++++++++++++++
   end subroutine det_real_matrix

!=====================================================================
   subroutine inv_real_matrix(ier,n,a,ainv)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: n
   real(8),intent(in)  :: a(n,n)
   integer,intent(out) :: ier
   real(8),intent(out) :: ainv(n,n)
   integer :: i, j
   real(8) :: even_odd
   integer,allocatable :: ipiv(:)
   real(8),allocatable :: a_lu(:,:)
  !++++++++++++++++++++++++++++
   allocate(a_lu(n,n),ipiv(n))
  !++++++++++++++++++++++++++++
   ier = 0
   a_lu(:,:) = 0.d0
   ainv(:,:) = 0.d0
   do i = 1,n
      ainv(i,i) = 1.d0
      do j = 1,n
         a_lu(i,j) = a(i,j)
      end do
   end do
   call lu_real_matrix(ier,n,a_lu,ipiv,even_odd)
   if (ier /= 0) then
      go to 99
   end if
   do j = 1,n
      call bk_real_matrix(ier,n,a_lu,ipiv,ainv(1,j))
      if (ier /= 0) then
         go to 99
      end if
   end do
99 continue
  !++++++++++++++++++++++
   deallocate(a_lu,ipiv)
  !++++++++++++++++++++++
   end subroutine inv_real_matrix

!=====================================================================
   subroutine axb_real_matrix(ier,n,m,a,x,b)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: n, m
   real(8),intent(in)  :: a(n,n), b(n,m)
   integer,intent(out) :: ier
   real(8),intent(out) :: x(n,m)
   integer :: i
   integer :: j
   real(8) :: even_odd
   real(8) :: rr, rr_old, res
   integer,allocatable :: ipiv(:)
   real(8),allocatable :: a_lu(:,:)
   real(8),allocatable :: z(:)
  !+++++++++++++++++++++++++++++++++
   allocate(a_lu(n,n),ipiv(n),z(n))
  !+++++++++++++++++++++++++++++++++
   ier = 0
   a_lu(:,:) = a(:,:)
   x(:,:) = b(:,:)
   call lu_real_matrix(ier,n,a_lu,ipiv,even_odd)
   if (ier /= 0) then
      go to 99
   end if
   do j = 1,m
      call bk_real_matrix(ier,n,a_lu,ipiv,x(1,j))
      if (ier /= 0) then
         go to 99
      end if
   end do
   rr = 1.d100
   do
      rr_old = rr
      rr = 0.d0
      do j = 1,m
         z(:) = x(:,j)
         call improve_axb_real_matrix(ier,n,a,x(1,j),b(1,j),a_lu,ipiv)
         if (ier /= 0) then
            go to 99
         end if
         do i = 1,n
            rr = rr + (z(i)-x(i,j))**2
         end do
      end do
      if (rr < rr_old) then
         cycle
      else
         exit
      end if
   end do
   res = sqrt(rr)
99 continue
  !++++++++++++++++++++++++
   deallocate(a_lu,ipiv,z)
  !++++++++++++++++++++++++
   end subroutine axb_real_matrix

!=====================================================================
   subroutine lu_real_matrix(ier,n,a,ipiv,even_odd)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)    :: n
   real(8),intent(inout) :: a(n,n)
   integer,intent(out)   :: ier, ipiv(n)
   real(8),intent(out)   :: even_odd
   integer :: i_max, i, j, k
   real(8) :: a_max, sum, tmp
   real(8),parameter :: TINY = 1.d-40
   real(8),allocatable :: scaling_row(:)
   ier = 0
  !+++++++++++++++++++++++++
   allocate(scaling_row(n))
  !+++++++++++++++++++++++++
   even_odd = 1.d0
   do i = 1,n
      a_max = 0.d0
      do j = 1,n
         if (abs(a(i,j)) > a_max) then
            a_max = abs(a(i,j))
         end if
      end do
      if (a_max == 0.d0) then
         ier = 1 ; go to 99
      end if
      scaling_row(i) = 1.d0/a_max
   end do
   do j = 1,n
      do i = 1,j-1
         sum = a(i,j)
         do k = 1,i-1
            sum = sum - a(i,k)*a(k,j)
         end do
         a(i,j) = sum
      end do
      a_max = 0.d0
      do i = j,n
         sum = a(i,j)
         do k = 1,j-1
            sum = sum - a(i,k)*a(k,j)
         end do
         a(i,j) = sum
         tmp = scaling_row(i)*abs(sum)
         if (tmp > a_max) then
            i_max = i
            a_max = tmp
         end if
      end do
      if (j /= i_max) then
         do k = 1,n
            tmp = a(i_max,k)
            a(i_max,k) = a(j,k)
            a(j,k) = tmp
         end do
         even_odd = - even_odd
         scaling_row(i_max) = scaling_row(j)
      end if
      ipiv(j) = i_max
      if (a(j,j) == 0.d0) then
         a(j,j) = TINY
      end if
      if (j /= n) then
         tmp = 1.d0/a(j,j)
         do i = j+1,n
            a(i,j) = a(i,j) * tmp
         end do
      end if
   end do
99 continue
  !++++++++++++++++++++++++
   deallocate(scaling_row)
  !++++++++++++++++++++++++
   end subroutine lu_real_matrix

!=====================================================================
   subroutine bk_real_matrix(ier,n,a,ipiv,b)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)    :: n, ipiv(n)
   real(8),intent(in)    :: a(n,n)
   real(8),intent(inout) :: b(n)
   integer,intent(out)   :: ier
   integer :: i, j, k, ip
   real(8) :: sum
   ier = 0
   k = 0
   do i = 1,n
      ip = ipiv(i)
      sum = b(ip)
      b(ip) = b(i)
      if (k /= 0) then
         do j = k,i-1
            sum = sum - a(i,j)*b(j)
         end do
      else if (sum /= 0.d0) then
         k = i
      end if
      b(i) = sum
   end do
   do i = n,1,-1
      sum = b(i)
      do j = i+1,n
         sum = sum - a(i,j)*b(j)
      end do
      b(i) = sum/a(i,i)
   end do
99 continue
   end subroutine bk_real_matrix

!=====================================================================
   subroutine improve_axb_real_matrix(ier,n,a,x,b,a_lu,ipiv)
!=====================================================================
!
!  Improves X of a linear equation A*X = B
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(out)   :: ier
   integer,intent(in)    :: n, ipiv(n)
   real(8),intent(in)    :: a(n,n), b(n), a_lu(n,n)
   real(8),intent(inout) :: x(n)
   real(8),allocatable :: r(:)
   ier = 0
  !+++++++++++++++
   allocate(r(n))
  !+++++++++++++++
   r(:) = matmul(a(:,:),x(:)) - b(:)
   call bk_real_matrix(ier,n,a_lu,ipiv,r)
   if (ier /= 0) then
      go to 99
   end if
   x(:) = x(:) - r(:)
  !++++++++++++++
   deallocate(r)
  !++++++++++++++
99 continue
   end subroutine improve_axb_real_matrix
