! **********************************************************************************
! *                ROUTINES FOR SOLVING LINEAR ALGEBRAIC EQUATIONS                 *
! *     -----------------------------------------------------------------------    *
! *     Partial list of subroutines:                                               *
! *        inverse_matrix ,    LU_SYSTEM,    LU_SYSTEM_DIRECT,     LUDCMP,         *
! *        LUBKSB,             LU,           equilibrate,          LUDCMP1,        *
! *        LUBKSB1,            LU1,          BICGSTAB,             Precond,        *
! *        MatSolve,           readinputMatrSolv                                   *
! **********************************************************************************
subroutine inverse_matrix (a, nap, map, b, nbp, mbp, n)
!------------------------------------------------------------------------------------
! The routine computes the inverse of a matrix, i.e., B(n,n) = [A(n,n)]^(-1).       !
!                                                                                !
! Input parameters:                                                                 !
! - a (complex array) - square matrix.                                              !
! - nap, map (integer variables) - specify the physical dimensions of the           !
!   matrix a.                                                                       !
! - nbp, mbp (integer variables) - specify the physical dimensions of the           !
!   inverse matrix.                                                                 !
! - n (integer) - real dimension of the square matrix.                              !
!                                                                                !
! Output parameter:                                                                 !
! - b (complex array) - inverse of the matrix a.                                    !
!                                                                                !
! The model control parameters specified in the file "../INPUTFILES/Input.dat" are  !
! given below.                                                                      !
!                                                                                !
! - TypeMatrSolv (character array) - specifies the method for solving linear        !
!   algebraic equations. The permissive values are:                                 !
!   - 'LU1'  - LU decomposition method from Numerical Recipes,                      !
!   - 'LU2'  - LU decomposition method from Lapack library,                         !
!   - 'LU3'  - LU decomposition method from Lapack library with solution            !
!      improvement,                                                                 !
!   - 'BICG' - Bi-Conjugate-Gradients method.                                       !
!   The recommended value of the parameter TypeMatrSolv is 'LU2'.                   !
!                                                                                !
! - itmax (integer) - maximum number of iteration for the 'LU3' method or BICG      !
!   method.                                                                         !
!                                                                                !
! - TypePrecond (character array) - specifies the type of preconditioning for the   !
!   BICG method. The permissive values are:                                         !
!   - 'NEUMANN' - incomplete Neumann series,                                        !
!   - 'SILU'    - incomplete LU factorization,                                      !
!   - ' '       - diagonal elements of the matrix.                                  !
!                                                                                !
! - NPrecOrder (integer) - truncation order of the Neumann series. This parameter   !
!   is used if TypePrecond = 'NEUMANN'.                                              !
!                                                                                !
! - epsilon (real) - solution tolerance for the BICG method.                        !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: n, nap, map, nbp, mbp
  complex(O) :: a(nap,map), b(nbp,mbp)
!
  integer    :: i, j, itmax, NPrecOrder
  real(O)    :: d, epsilon
  integer,allocatable    :: indx(:)
  real(O),allocatable    :: row(:), column(:)
  complex(O),allocatable :: c(:)
  character(20)          :: TypeMatrSolv, TypePrecond
!
  call readinputMatrSolv ( TypeMatrSolv, itmax, TypePrecond, NPrecOrder, epsilon )
  if (TypeMatrSolv(1:3) == 'LU1') then
    call identity_matrix (n, b, nbp, mbp)
    allocate (indx(n), c(n), row(n), column(n))
    call equilibrate (a, nap, map, n, n, row, column)
    call LUDCMP (a, nap, map, n, indx, d)
    do j = 1, n
      do i = 1, n
        c(i) = b(i,j) * row(i)
      end do
      call LUBKSB (a, nap, map, n, indx, c)
      do i = 1, n
        b(i,j) = c(i) * column(i)
      end do
    end do
    deallocate (indx, c, row, column)
  else if (TypeMatrSolv(1:3) == 'LU2') then
    call identity_matrix (n, b, nbp, mbp)
    allocate (indx(n), row(n), column(n))
    call equilibrate (a, nap, map, n, n, row, column)
    call LUDCMP1 (a, nap, map, n, indx)
    do j = 1, n
      do i = 1, n
        b(i,j) = row(i) * b(i,j)
      end do
    end do
    call LUBKSB1 (a, nap, map, n, n, indx, b, nbp, mbp)
    do j = 1, n
      do i = 1, n
        b(i,j) = column(i) * b(i,j)
      end do
    end do
    deallocate (indx, row, column)
  else if (TypeMatrSolv(1:3) == 'LU3') then
    call identity_matrix (n, b, nbp, mbp)
    allocate (row(n), column(n))
    call equilibrate (a, nap, map, n, n, row, column)
    do j = 1, n
      do i = 1, n
        b(i,j) = row(i) * b(i,j)
      end do
    end do
    call LU1 (a, nap, map, b, nbp, mbp, n, n, itmax)
    do j = 1, n
      do i = 1, n
        b(i,j) = column(i) * b(i,j)
      end do
    end do
    deallocate (row, column)
  else if (TypeMatrSolv(1:4) == 'BICG') then
    call identity_matrix (n, b, nbp, mbp)
    call BICGSTAB (TypePrecond, NPrecOrder, itmax, epsilon, n, n, a, nap, map,      &
         b, nbp, mbp)
  end if
end subroutine inverse_matrix
! ***********************************************************************************
subroutine LU_SYSTEM (a, nap, map, b, nbp, mbp, n)
!------------------------------------------------------------------------------------
! Given the square matrices a and b, the routine computes                           !
!                      x(n,n) = b(n,n) * a(n,n)^(-1)                                !
! using the following scheme:                                                       !
! - transpose the matrices a and b, i.e. compute a(n,n)^T and b(n,n)^T,             !
! - compute y(n,n) = [a(n,n)^T]^(-1) * b(n,n)^T, that is, solve the matrix system   !
!   [a(n,n)^T] * y(n,n) = b(n,n)^T, with y being stored in b,                       !
! - transpose the matrix y, i.e. compute x(n,n)= y(n,n)^T                           !
!                                                                                !
! Input parameters:                                                                 !
! - a (complex array) - square matrix.                                              !
! - nap, map (integer variables) - specify the physical dimensions of the           !
!   matrix a.                                                                       !
! - nbp, mbp (integer variables) - specify the physical dimensions of the           !
!   matrix b.                                                                       !
! - n (integer) - real dimension of the square matrices.                            !
!                                                                                !
! Input/Output parameter:                                                           !
! - b (complex array) - input matrix b and output matrix x.                         !
!                                                                                !
! The model control parameters TypeMatrSolv, itmax, TypePrecond, NPrecOrder and     !
! epsilon are specified in the file "../INPUTFILES/Input.dat".                      !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: n, nap, map, nbp, mbp
  complex(O) :: a(nap,map), b(nbp,mbp)
!
  integer    :: i, j, itmax, NPrecOrder
  real(O)    :: d, epsilon
  integer,allocatable    :: indx(:)
  real(O),allocatable    :: row(:), column(:)
  complex(O),allocatable :: c(:)
  character(20)          :: TypeMatrSolv, TypePrecond
!
  call readinputMatrSolv ( TypeMatrSolv, itmax, TypePrecond, NPrecOrder, epsilon )
  if (TypeMatrSolv(1:3) == 'LU1') then
    allocate (indx(n), c(n), row(n), column(n))
    call transpose (a, nap, map, n)
    call transpose (b, nbp, mbp, n)
    call equilibrate (a, nap, map, n, n, row, column)
    call LUDCMP (a, nap, map, n, indx, d)
    do j = 1, n
      do i = 1, n
        c(i) = b(i,j) * row(i)
      end do
      call LUBKSB (a, nap, map, n, indx, c)
      do i = 1, n
        b(i,j) = c(i) * column(i)
      end do
    end do
    call transpose (b, nbp, mbp, n)
    deallocate (indx, c, row, column)
  else if (TypeMatrSolv(1:3) == 'LU2') then
    allocate (indx(n), row(n), column(n))
    call transpose (a, nap, map, n)
    call transpose (b, nbp, mbp, n)
    call equilibrate (a, nap, map, n, n, row, column)
    call LUDCMP1 (a, nap, map, n, indx)
    do j = 1, n
      do i = 1, n
        b(i,j) = row(i) * b(i,j)
      end do
    end do
    call LUBKSB1 (a, nap, map, n, n, indx, b, nbp, mbp)
    do j = 1, n
      do i = 1, n
        b(i,j) = column(i) * b(i,j)
      end do
    end do
    call transpose (b, nbp, mbp, n)
    deallocate (indx, row, column)
  else if (TypeMatrSolv(1:3) == 'LU3') then
    allocate (row(n), column(n))
    call transpose (a, nap, map, n)
    call transpose (b, nbp, mbp, n)
    call equilibrate (a, nap, map, n, n, row, column)
    do j = 1, n
      do i = 1, n
        b(i,j) = row(i) * b(i,j)
      end do
    end do
    call LU1 (a, nap, map, b, nbp, mbp, n, n, itmax)
    do j = 1, n
      do i = 1, n
        b(i,j) = column(i) * b(i,j)
      end do
    end do
    call transpose (b, nbp, mbp, n)
    deallocate (row, column)
  else if (TypeMatrSolv(1:4) == 'BICG') then
    call transpose (a, nap, map, n)
    call transpose (b, nbp, mbp, n)
    call BICGSTAB (TypePrecond, NPrecOrder, itmax, epsilon, n, n, a, nap, map,      &
         b, nbp, mbp)
    call transpose (b, nbp, mbp, n)
  end if
end subroutine LU_SYSTEM
! ***********************************************************************************
subroutine LU_SYSTEM_DIRECT (a, nap, map, b, nbp, mbp, n, m)
!------------------------------------------------------------------------------------
! The routine computes                                                              !
!                    x(n,m) = [a(n,n)]^(-1) * b(n,m),                               !
! that is, solves the matrix system                                                 !
!                    a(n,n) * x(n,m) = b(n,m),                                      !
! with x being stored in b.                                                         !
!                                                                                !
! Input parameters:                                                                 !
! - a (complex array) - square matrix.                                              !
! - nap, map (integer variables) - specify the physical dimensions of the           !
!   matrix a.                                                                       !
! - nbp, mbp (integer variables) - specify the physical dimensions of the           !
!   matrix b.                                                                       !
! - n (integer) - real dimension of the matrix a. n also specifies the number of    !
!                 lines of the matrix b.                                            !
! - m (integer) - specifies the number of columns of the matrix b.                  !
!                                                                                !
! Input/Output parameter:                                                           !
! - b (complex array) - input matrix b and output matrix x.                         !
!                                                                                !
! The model control parameters TypeMatrSolv, itmax, TypePrecond, NPrecOrder and     !
! epsilon are specified in the file "../INPUTFILES/Input.dat".                      !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: n, m, nap, map, nbp, mbp
  complex(O) :: a(nap,map), b(nbp,mbp)
!
  integer    :: i, j, itmax, NPrecOrder
  real(O)    :: d, epsilon
  integer,allocatable    :: indx(:)
  real(O),allocatable    :: row(:), column(:)
  complex(O),allocatable :: c(:)
  character(20)          :: TypeMatrSolv, TypePrecond
!
  call readinputMatrSolv ( TypeMatrSolv, itmax, TypePrecond, NPrecOrder, epsilon )
  if (TypeMatrSolv(1:3) == 'LU1') then
    allocate (indx(n), c(n), row(n), column(n))
    call equilibrate (a, nap, map, n, n, row, column)
    call LUDCMP (a, nap, map, n, indx, d)
    do j = 1, m
      do i = 1, n
        c(i) = b(i,j) * row(i)
      end do
      call LUBKSB (a, nap, map, n, indx, c)
      do i = 1, n
        b(i,j) = c(i) * column(i)
      end do
    end do
    deallocate (indx, c, row, column)
  else if (TypeMatrSolv(1:3) == 'LU2') then
    allocate (indx(n), row(n), column(n))
    call equilibrate (a, nap, map, n, n, row, column)
    call LUDCMP1 (a, nap, map, n, indx)
    do j = 1, m
      do i = 1, n
        b(i,j) = row(i) * b(i,j)
      end do
    end do
    call LUBKSB1 (a, nap, map, n, m, indx, b, nbp, mbp)
    do j = 1, m
      do i = 1, n
        b(i,j) = column(i) * b(i,j)
      end do
    end do
    deallocate (indx, row, column)
  else if (TypeMatrSolv(1:3) == 'LU3') then
    allocate (row(n), column(n))
    call equilibrate (a, nap, map, n, n, row, column)
    do j = 1, m
      do i = 1, n
        b(i,j) = row(i) * b(i,j)
      end do
    end do
    call LU1 (a, nap, map, b, nbp, mbp, n, m, itmax)
    do j = 1, m
      do i = 1, n
        b(i,j) = column(i) * b(i,j)
      end do
    end do
    deallocate (row, column)
  else if (TypeMatrSolv(1:4) == 'BICG') then
  call BICGSTAB (TypePrecond, NPrecOrder, itmax, epsilon, n, m, a, nap, map,      &
       b, nbp, mbp)
  end if
end subroutine LU_SYSTEM_DIRECT
! ***********************************************************************************
subroutine readinputMatrSolv ( TypeMatrSolv, itmax, TypePrecond, NPrecOrder, epsilon )
  use parameters
  implicit none
  integer       :: ios, itmax, NPrecOrder
  real(O)       :: epsilon
  character(20) :: TypeMatrSolv, TypePrecond
  character(80) :: string
  logical       :: XFindPar
!
  open (unit = iInput, file = FileInput, status = "old", position = "rewind")
  TypeMatrSolv = 'LU1'
  itmax        = 10
  TypePrecond  = 'NEUMANN'
  NPrecOrder   = 6
  epsilon      = 1.e-6_O
  string       = 'MatrixSolver'
  if (XFindPar (iInput, string)) then
    read (iInput, *, iostat = ios) TypeMatrSolv
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable TypeMatrSolv;')"
      stop
    end if
    read (iInput, *, iostat = ios) itmax
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable itmax;')"
      stop
    end if
    read (iInput, *, iostat = ios) TypePrecond
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable TypePrecond;')"
      stop
    end if
    read (iInput, *, iostat = ios) NPrecOrder
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable NPrecOrder;')"
      stop
    end if
    read (iInput, *, iostat = ios) epsilon
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable epsilon;')"
      stop
    end if
  else
    print "(/,2x,'Group name MatrixSolver not found;')"
    stop
  end if
  call check_MatrixSolver (TypeMatrSolv)
  close (unit = iInput)
end subroutine readinputMatrSolv
! ************************************************************************************
! *               LU DECOMPOSITION - F90-VERSION FROM NUMERICAL RECIPES              *
! ************************************************************************************
subroutine LUDCMP (a, np, mp, n, indx, d)
  use parameters
  use derived_parameters
  implicit none
  integer    :: n, np, mp, indx(n)
  real(O)    :: d
  complex(O) :: a(np,mp)
!
  integer    :: imax, i, j, k
  real(O)    :: aamax, tampon
  complex(O) :: sum, dum
  complex(O),allocatable :: vv(:)
!
  allocate (vv(n))
  d = 1._O
  do i = 1, n
    aamax = 0._O
    do j = 1, n
      if (abs(a(i,j)) > aamax) aamax = abs(a(i,j))
    end do
    if (aamax < SmallestPosNumber) then
      print "(/,2x,'Error in subroutine LUDCMP in module MatrixSolv: singularity,')"
      print "(  2x,'the matrix inversion can not be performed with the LU ')"
      print "(  2x,'algorithm from Numerical Recipes;')"
      stop
    end if
    tampon = 1._O / aamax
    vv(i)  = cmplx(tampon,0.0,O)
  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
    aamax = 0._O
    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
      dum    = vv(i) * abs(sum)
      if (abs(dum) >= aamax) then
        imax  = i
        aamax = abs(dum)
      end if
    end do
    if (j /= imax) then
      do k = 1, n
        dum       = a(imax,k)
        a(imax,k) = a(j,k)
        a(j,k)    = dum
      end do
      d = - d
      vv(imax) = vv(j)
    end if
    indx(j) = imax
    if (abs(a(j,j)) < SmallestPosNumber) a(j,j) = cmplx(ZeroLUVal,ZeroLUVal,O)
    if (j /= n) then
      dum = 1._O / a(j,j)
      do  i = j + 1, n
        a(i,j) = a(i,j) * dum
      end do
    end if
  end do
  deallocate (vv)
end subroutine LUDCMP
! **********************************************************************************
subroutine LUBKSB (a, np, mp, n, indx, b)
  use parameters
  implicit none
  integer    :: n, np, mp, indx(n)
  complex(O) :: a(np,mp), b(n)
!
  integer    :: i, j, ii, ll
  complex(O) :: sum
!
  ii = 0
  do i = 1, n
    ll    = indx(i)
    sum   = b(ll)
    b(ll) = b(i)
    if (ii /= 0) then
      do j = ii, i - 1
        sum = sum - a(i,j) * b(j)
      end do
    else if (abs(sum) /= 0._O) then
      ii = i
    end if
    b(i) = sum
  end  do
  do i = n, 1, -1
    sum = b(i)
    if (i < n) then
      do j = i + 1, n
        sum = sum - a(i,j) * b(j)
      end do
    end if
    b(i) = sum / a(i,i)
  end do
end subroutine LUBKSB
! **********************************************************************************
subroutine LU (a, np, mp, b, n)
  use parameters
  implicit none
  integer    :: n, np, mp
  complex(O) :: a(np,mp), b(n)
!
  real(O)    :: d
  integer,allocatable :: indx(:)
!
  allocate (indx(n))
  call LUDCMP (a, np, mp, n, indx, d)
  call LUBKSB (a, np, mp, n, indx, b)
  deallocate (indx)
end subroutine LU
! ***********************************************************************************
subroutine equilibrate (a, np, mp, n, m, r, c)
! ----------------------------------------------------------------------------------
! This subroutine computes row and column scalings intended to equilibrate         !
! a matrix a and reduce its condition number. The equilibrated matrix anew is      !
!                   anew = r * a * c,                                              !
! where r and c are real diagonal matrices. Therefore                              !
!                   a = r^(-1) * anew * c^(-1).                                    !
! ----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: np, mp, n, m
  real(O)    :: r(m), c(n)
  complex(O) :: a(np,mp)
!
  integer    :: i, j
  real(O)    :: smlnum, bignum, norm, rcmin, rcmax, amax, rowcnd, colcnd, cj, tresh
!
  smlnum = sqrt(SmallestPosNumber)
  bignum = 1._O / smlnum
  tresh  = 1.e-2_O
  do i = 1, m
    r(i) = 0._O
  end do
  do j = 1, n
    do i = 1, m
      norm = abs(real(a(i,j),O)) + abs(aimag(a(i,j)))
      r(i) = max(r(i), norm)
    end do
  end do
  rcmin = bignum
  rcmax = 0._O
  do i = 1, m
    rcmax = max(rcmax, r(i))
    rcmin = min(rcmin, r(i))
  end do
  amax  = rcmax
  if (rcmin == 0._O) then
    do i = 1, m
      if (r(i) == 0._O) then
        print "(/,2x,'Error in subroutine equilibrate in module MatrixSolv:')"
        print "(  2x,'the row ',i5,' of the matrix is exactly zero;')", i
        stop
      end if
    end do
  else
    do i = 1, m
      r(i) = 1._O / min(max(r(i), smlnum), bignum)
    end do
    rowcnd = max(rcmin, smlnum) / min(rcmax, bignum)
  end if
!
  do j = 1, n
    c(j) = 0._O
  end do
  do j = 1, n
    do i = 1, m
      norm = abs(real(a(i,j),O)) + abs(aimag(a(i,j)))
      c(j) = max(c(j), norm * r(i))
    end do
  end do
  rcmin = bignum
  rcmax = 0._O
  do j = 1, n
    rcmax = max(rcmax, c(j))
    rcmin = min(rcmin, c(j))
  end do
  if (rcmin == 0._O) then
    do j = 1, n
      if (c(j) == 0._O) then
        print "(/,2x,'Error in subroutine equilibrate in module MatrixSolv:')"
        print "(  2x,'the column ',i5,' of the matrix is exactly zero;')", j
        stop
      end if
    end do
  else
    do j = 1, n
      c(j) = 1._O / min(max(c(j), smlnum), bignum)
    end do
    colcnd = max(rcmin, smlnum) / min(rcmax, bignum)
  end if
!
  if (rowcnd >= tresh .and. amax >= smlnum .and. amax <= bignum) then
   if (colcnd >= tresh) then
     do i = 1, m
       r(i) = 1._O
     end do
     do j = 1, n
       c(j) = 1._O
     end do
   else
     do j = 1, n
       cj = c(j)
       do i = 1, m
         a(i,j) = a(i,j) * cj
       end do
     end do
     do i = 1, m
       r(i) = 1._O
     end do
   end if
 else if (colcnd >= tresh) then
   do j = 1, n
     do i = 1, m
       a(i,j) = r(i) * a(i,j)
     end do
   end do
   do j = 1, n
     c(j) = 1._O
   end do
 else
   do j = 1, n
     cj = c(j)
     do i = 1, m
       a(i,j)= r(i) * a(i,j) * cj
     end do
   end do
 end if
end subroutine equilibrate
! ***********************************************************************************
! *            LU DECOMPOSITION - SIMPLIFIED VERSIONS FROM LAPACK LIBRARY           *
! ***********************************************************************************
subroutine LUDCMP1 (a, nap, map, n, ipiv)
  use parameters
  use derived_parameters
  implicit none
  integer    :: n, nap, map, ipiv(n)
  complex(O) :: a(nap,map)
!
  integer    :: j, nt, imax, jp, i, k, l
  real(O)    :: amax
  complex(O) :: temp
!
  do j = 1, n
    nt   = n - j + 1
    imax = 1
    if (nt > 1) then
      amax = abs(a(j,j))
      do i = 2, nt
        if (abs(a(j+i-1,j)) > amax) then
          imax = i
          amax = abs(a(j+i-1,j))
        end if
      end do
    end if
    nt = n - j
    jp = j - 1 + imax
    ipiv(j) = jp
    if (abs(a(jp,j)) > SmallestPosNumber) then
      if (jp /= j) then
        do i = 1, n
          temp    = a(j,i)
          a(j,i)  = a(jp,i)
          a(jp,i) = temp
        end do
      end if
      if (j < n) then
        temp = one / a(j,j)
        do i = 1,nt
          a(j+i,j) = temp * a(j+i,j)
        end do
      end if
    else
      print "(/,2x,'Error in subroutine LUDCMP1 in module MatrixSolv: singularity,')"
      print "(  2x,'the matrix inversion can not be performed with the LU ')"
      print "(  2x,'algorithm from Lapack library;')"
      stop
    end if
    if (j < n) then
      do k = 1, nt
        if (a(j,j+k) /= zero) then
          temp = - one * a(j,j+k)
          do l = 1, nt
            a(j+l,j+k) = a(j+l,j+k) + a(j+l,j) * temp
          end do
        end if
      end do
    end if
  end do
end subroutine LUDCMP1
! **********************************************************************************
subroutine LUBKSB1 (a, nap, map, n, m, ipiv, b, nbp, mbp)
  use parameters
  implicit none
  integer    :: n, m, nap, map, nbp, mbp, ipiv(n)
  complex(O) :: a(nap,map), b(nbp,mbp)
!
  integer    :: i, ip, k, j
  complex(O) :: temp
!
  do i = 1, n
    ip = ipiv(i)
    if (ip /= i) then
      do k = 1, m
        temp    = b(i,k)
        b(i,k)  = b(ip,k)
        b(ip,k) = temp
      end do
    end if
  end do
  do j = 1, m
    do k = 1, n
      if (b(k,j) /= zero) then
        do i = k + 1, n
          b(i,j) = b(i,j) - b(k,j) * a(i,k)
        end do
      end if
    end do
  end do
  do j = 1, m
    do k = n, 1, - 1
      if (b(k,j) /= zero ) then
        b(k,j) = b(k,j) / a(k,k)
        do i = 1, k - 1
          b(i,j) = b(i,j) - b(k,j) * a(i,k)
        end do
      end if
    end do
  end do
end subroutine LUBKSB1
! **********************************************************************************
subroutine LU1 (a, nap, map, b, nbp, mbp, n, m, itmax)
  use parameters
  use derived_parameters
  implicit none
  integer    :: n, m, nap, map, nbp, mbp, itmax
  complex(O) :: a(nap,map), b(nbp,mbp)
!
  integer    :: i, j, k, nz, count
  real(O)    :: eps, safemin, safe1, safe2, lstres, s, absb, absx, absa, absw
  complex(O) :: sum
  logical    :: more
  integer,allocatable    :: ipiv(:)
  real(O),allocatable    :: rwork(:), berr(:)
  complex(O),allocatable :: af(:,:), x(:,:), work(:,:)
!
  allocate (ipiv(nap), af(nap,map), x(nbp,mbp), work(nbp,1), rwork(nap), berr(mbp))
  do i = 1, n
    do j = 1, n
      af(i,j) = a(i,j)
    end do
    do j = 1, m
      x(i,j) = b(i,j)
    end do
  end do
  call LUDCMP1 (af, nap, map, n, ipiv)
  call LUBKSB1 (af, nap, map, n, m, ipiv, x, nbp, mbp)
!
  nz  = n + 1
  eps = MachEps
  safemin = SmallestPosNumber
  safe1   = nz * safemin
  safe2   = safe1 / eps
  do j = 1, m
    count  = 1
    lstres = 3._O
    more   = .true.
    do while (more)
      do i = 1, n
        work(i,1) = b(i,j)
      end do
      do i = 1, n
        sum = zero
        do k = 1, n
          sum = sum + a(i,k) * x(k,j)
        end do
        work(i,1) = work(i,1) - sum
      end do
      do i = 1, n
        absb = abs(real(b(i,j))) + abs(aimag(b(i,j)))
        rwork(i) = absb
      end do
      do k = 1, n
        absx = abs(real(x(k,j))) + abs(aimag(x(k,j)))
        do i = 1, n
          absa = abs(real(a(i,k))) + abs(aimag(a(i,k)))
          rwork(i) = rwork(i) + absa * absx
        end do
      end do
      s = 0._O
      do i = 1, n
        absw = abs(real(work(i,1))) + abs(aimag(work(i,1)))
        if (rwork(i) > safe2 ) then
          s = max(s,absw / rwork(i))
        else
          s = max(s,(absw + safe1) / (rwork(i) + safe1))
        end if
      end do
      berr(j) = s
      more = .false.
      if (berr(j) > eps .and. 2._O * berr(j) <= lstres .and. count <= itmax) then
        more = .true.
        call LUBKSB1 (af, nap, map, n, 1, ipiv, work, nbp, 1)
        do i = 1, n
          x(i,j) = x(i,j) + work(i,1)
        end do
        lstres = berr(j)
        count  = count + 1
      end if
    end do
  end do
  do i = 1, n
    do j = 1, m
      b(i,j) = x(i,j)
    end do
  end do
  deallocate (ipiv, af, x, work, rwork, berr)
end subroutine LU1
! ***********************************************************************************
! *                                BICG Method                                      *
! ***********************************************************************************
subroutine BICGSTAB (TypePrecond, NPrecOrder, Niter, eps, n, m, a, nap, map,         &
           b, nbp, mbp)
  use parameters
  implicit none
  integer       :: NPrecOrder, Niter, n, m, nap, map, nbp, mbp
  real (O)      :: eps
  complex(O)    :: a(nap,map), b(nbp,mbp)
  character(20) :: TypePrecond

  integer       :: i, j, k
  real(O)       :: error, normvct, normy, invnormy, normt, normt2
  complex(O)    :: alpha, beta, ro, roold, omega, cdot, vr0, minus_one, beta_omega,  &
                   roold_omega
  logical       :: more
  complex(O),allocatable :: r(:), r0(:), p(:), v(:), s(:), t(:), x(:), y(:),         &
                            q1(:), q2(:), pold(:), xold(:), dx(:), pm(:,:), pm0(:)
!
  minus_one = - one
  allocate (r(n), r0(n), p(n), v(n), s(n), t(n), q1(n), q2(n), pold(n), xold(n), dx(n))
  allocate (x(n), y(n))
  if (TypePrecond(1:7) == 'NEUMANN' .or. TypePrecond(1:4) == 'SILU') then
    allocate (pm(n,n))
    call Precond (TypePrecond, NPrecOrder, a, nap, map, pm, n, n, n)
  else
    allocate (pm0(n))
    do i = 1, n
      pm0(i) = one / a(i,i)
    end do
  end if
  do j = 1, m
    do i = 1, n
      y(i) = b(i,j)
    end do
    normy = normvct (n, y)
    if (normy == 0._O) then
      do i = 1, n
        x(i) = zero
      end do
      go to 1
    end if
    invnormy = 1._O / normy
    call copy_vector (y, xold, n)
    call product_matrix_vector3 (n, n, a, nap, map, xold, y, minus_one, one, r0)
    if (normvct (n, r0) == 0._O) then
      call copy_vector (xold, x, n)
      go to 1
    end if
    call copy_vector (r0, r, n)
    more = .true.
    k    = 0
    do while (more)
      k  = k + 1
      ro = cdot (n, r, r0)
      if (abs(ro) == 0._O) then
        call copy_vector (r0, r, n)
        ro = cdot (n, r, r0)
      end if
      if (k == 1) then
        call copy_vector (r, p, n)
      else
        roold_omega = roold * omega
        beta = ro * alpha / roold_omega
        beta_omega  = - beta * omega
        do i = 1, n
          p(i) = r(i) + beta * pold(i) + beta_omega * v(i)
        end do
      end if
      if (TypePrecond(1:7) == 'NEUMANN') then
        call product_matrix_vector  (n, n, pm, n, n, p, q1)
      else if (TypePrecond(1:4) == 'SILU') then
        call MatSolve (n, a, nap, map, pm, n, n, p, q1)
      else
        do i = 1, n
          q1(i) = p(i) * pm0(i)
        end do
      end if
      call product_matrix_vector (n, n, a, nap, map, q1, v)
      vr0 = cdot (n, v, r0)
      if (abs(vr0) /= 0._O) then
        alpha = ro / vr0
      else
        print "(/,2x,'Error in subroutine BICGSTAB: singularity,')"
        print "(  2x,'BICG algorithm can not be used for matrix inversion;')"
        stop
      end if
      do i = 1, n
        s(i) = r(i) - alpha * v(i)
      end do
      error = normvct (n,s) * invnormy
      if (error < eps) then
        do i = 1, n
          x(i) = xold(i) + alpha * q1(i)
        end do
        more = .false.
      else
        if (TypePrecond(1:7) == 'NEUMANN') then
          call product_matrix_vector  (n, n, pm, n, n, s, q2)
        else if (TypePrecond(1:4) == 'SILU') then
          call MatSolve (n, a, nap, map, pm, n, n, s, q2)
        else
          do i = 1, n
            q2(i) = s(i) * pm0(i)
          end do
        end if
        call product_matrix_vector (n, n, a, nap, map, q2, t)
        normt = normvct (n,t)
        if (normt /= 0._O) then
          normt2 = normt * normt
          omega  = cdot (n, s, t) / normt2
        else
          print "(/,2x,'Error in subroutine BICGSTAB: singularity,')"
          print "(  2x,'BICG algorithm can not be used for matrix inversion;')"
          stop
        end if
        do i = 1, n
          x(i) = xold(i) + alpha * q1(i) + omega * q2(i)
        end do
        do i = 1, n
          r(i) = s(i) - omega * t(i)
        end do
        do i = 1, n
          dx(i) = x(i) - xold(i)
        end do
        error = normvct (n, dx) * invnormy
        if (error < eps .or. k == Niter) then
          more = .false.
        else
          call copy_vector (x, xold, n)
          call copy_vector (p, pold, n)
          roold = ro
          if (abs(roold) == 0._O .or. abs(omega) == 0._O) then
            print "(/,2x,'Error in subroutine BICGSTAB: singularity,')"
            print "(  2x,'BICG algorithm can not be used for matrix inversion;')"
            stop
          end if
        end if
      end if
    end do
    if (k == Niter .and. error > eps) then
      print "(/,2x, a)",                                                             &
     'Error in subroutine BICGSTAB:  convergence is not achieved because'
      print "(  2x, a)",                                                             &
     'the tolerance TolConv or the iteration number NmaxIter are too low;'
      stop
    end if
1   continue
    do i = 1, n
      b(i,j) = x(i)
    end do
  end do
  deallocate (r, r0, p, v, s, t, q1, q2, pold, xold, dx, x, y)
  if (TypePrecond(1:7) == 'NEUMANN' .or. TypePrecond(1:4) == 'SILU') then
    deallocate (pm)
  else
    deallocate (pm0)
  end if
end subroutine BICGSTAB
!************************************************************************************
subroutine Precond (TypePrecond, Norder, a, nap, map, p, npp, mpp, n)
  use parameters
  implicit none
  integer       :: Norder, n, nap, map, npp, mpp
  complex(O)    :: a(nap,map), p(npp,mpp)
  character(20) :: TypePrecond
!
  integer       :: iorder, i, j, k, imax
  real(O)       :: maxl, absa
  complex(O)    :: sum, Yik, IP
  complex(O),allocatable :: c(:), d(:)
!
  call identity_matrix (n, p, npp, mpp)
  if (TypePrecond(1:7) == 'NEUMANN') then
    allocate (c(n), d(n))
    do j = 1, n
      maxl = 0._O
      do i = 1, n
        absa = abs(a(i,j))
        if (absa > maxl) then
          maxl = absa
          imax = i
        end if
      end do
      if (abs(a(imax,j)) /= 0._O) then
        d(j) = one / a(imax,j) / real(n * n,O)
      else
        print "(/,2x,'Error in subroutine Precond: singularity,')"
        print "(  2x,'Neumann preconditioning can not be used;')"
        stop
      end if
    end do
    do iorder = 1, Norder
      do j = 1, n
        do i = 1, n
          sum = zero
          do k = 1, n
            if (k == i) then
              Yik = one - a(i,k) * d(k)
            else
              Yik = - a(i,k) * d(k)
            end if
            sum = sum + Yik * p(k,j)
          end do
          c(i) = sum
        end do
        do i = 1, n
          p(i,j) = c(i)
          if (i == j) p(i,j) = p(i,j) + one
        end do
      end do
    end do
    do i = 1, n
      do j = 1, n
        p(i,j) = p(i,j) * d(i)
      end do
    end do
    deallocate (c, d)
  else if (TypePrecond(1:4) == 'SILU') then
    do i = 1, n
      sum = zero
      do j = 1, i - 1
        sum = sum + a(i,j) * P(j,j) * a(j,i)
      end do
      IP = a(i,i) - sum
      if (abs(IP) /= 0._O) then
        P(i,i) = one / IP
      else
        print "(/,2x,'Error in subroutine Precond: singularity,')"
        print "(  2x,'SILU preconditioning can not be used;')"
        stop
      end if
    end do
  end if
end subroutine Precond
!************************************************************************************
subroutine MatSolve (n, a, nap, map, p, npp, mpp, y, x)
  use parameters
  implicit none
  integer     :: n, nap, map, npp, mpp
  complex(O)  :: a(nap,map), p(npp,mpp), y(n), x(n)
!
  integer     :: i, j
  complex(O)  :: sum
  complex(O),allocatable :: z(:)
!
  allocate (z(n))
  z(1) = y(1) * p(1,1)
  do i = 2, n
    sum = zero
    do j = 1, i - 1
      sum = sum + a(i,j) * z(j)
    end do
    z(i) = ( y(i) - sum ) * p(i,i)
  end do
  x(n) = z(n)
  do i = n - 1, 1, -1
    sum = zero
    do j = i + 1, n
      sum = sum + a(i,j) * x(j)
    end do
    x(i) = z(i) - sum * p(i,i)
  end do
  deallocate (z)
end subroutine MatSolve


module quad
  use iso_c_binding
  use omp_lib
  implicit none

contains

! Compute the definite integral of 50/(pi*(2500*x**2+1)) from 0 to 10.
! Exact answer is atan(500)/pi ~ 0.499363.
function f_quad() bind(c)
  use iso_c_binding
  use omp_lib
  implicit none
  real(c_double) :: f_quad
  real(c_double) :: a=0.0, b=10.0, total=0.0, x
  real(c_double), parameter :: pi = 3.141592653589793D+00
  integer :: i
  integer,parameter :: n=10000000

!$omp target teams distribute parallel do reduction(+:total)
  do i = 1, n
    x = ( real(n-i,c_double)*a + real(i-1,c_double)*b ) / real(n-1,c_double)
    total = total + 50.0D+00 / (pi*(2500.0D+00*x*x+1.0D+00))
  end do
!$omp end target teams distribute parallel do

  total = (b - a) * total/real(n,c_double)
  f_quad = total
end function

end module


      subroutine sunrset(month,day,rlat,rise,set,sin_term,
     +                                          cos_term,reldst)
c
c -----------------------------------------------------------------
c  subroutine estimates a local time of sunrise and sunset
c  All equations from Dingman book, 2002
c  rlat - latitude
c  tnoon - local noon time
c  rise - local sun rise time
c  set - local sun set time
c  sin_term - sinus term in sun angle calculation
c  cos_term - cosine term in sun angle calculation
c  decline - declination of the sun
c  reldst - sun-earth eccentricity correction factor
c  Assumed that noon time = 12.0 for CONUS
c -----------------------------------------------------------------
c
      parameter (TNOON = 12.0)
      parameter (ROTV = 0.2618)
      integer ndays(12)/0,31,59,90,120,151,181,212,243,273,304,334/

      rlatr=rlat*3.14/180.
      nday=ndays(month)+day
      dangl=2*3.14*(nday-1)/365.
      decline=(0.006918-0.399912*cos(dangl)+0.070257*sin(dangl)-
     *         0.006758*cos(2*dangl)+0.000907*sin(2*dangl)-
     *         0.002697*cos(3*dangl)+0.00148*sin(3*dangl))
      reldst=1.00011+0.034221*cos(dangl)+0.00128*sin(dangl)+
     +           0.000719*cos(2*dangl)+0.000077*sin(2*dangl)
      z=acos(-tan(decline)*tan(rlatr))
      dts=z/ROTV
      rise=TNOON-dts
      set=TNOON+dts
      sin_term=sin(rlatr)*sin(decline)
      cos_term=cos(rlatr)*cos(decline)

      return
      end


! Program to test min and max intrinsics
program intrinsic_minmax
   implicit none
   integer i, j, k, m
   real r, s, t, u

   i = 1
   j = -2
   k = 3
   m = 4
   if (min (i, k) .ne. 1) call abort
   if (min (i, j, k, m) .ne. -2) call abort
   if (max (i, k) .ne. 3) call abort
   if (max (i, j, k, m) .ne. 4) call abort
   if (max (i+1, j) .ne. 2) call abort

   r = 1
   s = -2
   t = 3
   u = 4
   if (min (r, t) .ne. 1) call abort
   if (min (r, s, t, u) .ne. -2) call abort
   if (max (r, t) .ne. 3) call abort
   if (max (r, s, t, u) .ne. 4) call abort

   if (max (4d0, r) .ne. 4d0) call abort
   if (amax0 (i, j) .ne. 1.0) call abort
   if (min1 (r, s) .ne. -2) call abort

   ! Test simplify.
   if (min (1, -2, 3, 4) .ne. -2) call abort
   if (max (1, -2, 3, 4) .ne. 4) call abort
   if (amax0 (1, -2) .ne. 1.0) call abort
   if (min1 (1., -2.) .ne. -2) call abort

end program


    Program zpteqr_example

!     ZPTEQR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dznrm2
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: zhetrd, zlacpy, zpteqr, zungtr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Integer :: i, ifail, info, k, lda, ldz, lwork, n
      Character (1) :: uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), tau(:), work(:), z(:, :)
      Real (Kind=dp), Allocatable :: d(:), e(:), rwork(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, conjg, maxloc
!     .. Executable Statements ..
      Write (nout, *) 'ZPTEQR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldz = n
      lwork = 64*n
      Allocate (a(lda,n), tau(n), work(lwork), z(ldz,n), d(n), e(n), &
        rwork(4*n))

!     Read A from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)(a(i,i:n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)(a(i,1:i), i=1, n)
      End If

!     Reduce A to tridiagonal form T = (Q**H)*A*Q

      Call zhetrd(uplo, n, a, lda, d, e, tau, work, lwork, info)

!     Copy A into Z

      Call zlacpy(uplo, n, n, a, lda, z, ldz)

!     Form Q explicitly, storing the result in Z

      Call zungtr(uplo, n, z, ldz, tau, work, lwork, info)

!     Calculate all the eigenvalues and eigenvectors of A

      Call zpteqr('V', n, d, e, z, ldz, rwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else

!       Print eigenvalues and eigenvectors

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) d(1:n)
        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors, largest element real
        Do i = 1, n
          rwork(1:n) = abs(z(1:n,i))
          k = maxloc(rwork(1:n), 1)
          scal = conjg(z(k,i))/abs(z(k,i))/dznrm2(n, z(1,i), 1)
          z(1:n, i) = z(1:n, i)*scal
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, z, &
          ldz, 'Bracketed', 'F7.4', 'Eigenvectors', 'Integer', rlabs, &
          'Integer', clabs, 80, 0, ifail)

      End If

100   Format (8X, 4(F7.4,11X,:))
    End Program


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   pd1 :    Time integration of a scalar nonlinear parabolic PDE
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)
!
!      *Set the nonlinear term
       F(1)= PAR(1) * U(1) * ( 1. - U(1) )

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,X)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: X

      DOUBLE PRECISION pi

      pi=4*ATAN(1.d0)

!      *Set the (constant) parameter
       PAR(1) = 1.

!      *Set the actual width of the space interval [0,PAR(11)]
       PAR(11) = 10.

!      *Set the initial data in the (scaled) interval [0,1]
       U(1) = SIN(pi*X)

!      *Also set the space-derivative of the initial data
!      *Note the scaling by 1/PAR(11) !
       U(2) = pi * COS(pi*X)/PAR(11)

!      *Set the diffusion constant
       PAR(15) = 0.1

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

!      *Define the boundary conditions (Dirichlet, in this demo).
       FB(1)=U0(1)
       FB(2)=U1(1)

      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


program gauss_ppal

use gausspp_interface
use sistupf_interface
use datasissim_interface
use residuo_interface

implicit none

real, dimension(:,:), allocatable :: a
real, dimension(:,:), allocatable :: a_copia
real, dimension(:), allocatable :: b
real, dimension(:), allocatable :: b_copia
real, dimension(:), allocatable :: u
real, dimension(:), allocatable :: r

integer, dimension(:), allocatable :: l

real :: deter

integer :: n, i, j

print*
print*, 'Introduce o orde do sistema: '
read*, n
print*

n = 6

print*
print*, 'O orde introduce e: ', n
print*

allocate(a(n,n), a_copia(n,n), b(n), b_copia(n), u(n), r(n), l(n))

u = 0

do i=1,n
  do j =1,n
    if(i == j) then
      a(i,i) = 2
    else
      a(i,j) = j - i
    end if
  end do
  print *, a(i,:)
end do

do i =1,n
  b(i) = 2*i
end do

a_copia = a

b_copia = b

call gausspp(a, b, l, deter)

print*, 'Matriz A:'
do i=1,n
  print*, a(i,:)
end do

print *, 'Vector l:'
print*, l(:)

print *, 'B é:'
print*, b(:)

print *, 'Determinante :)'
print *, deter

call sistupf(a, b, l, u)
call residuo(a_copia, b_copia, u, r)

print*,
print*, 'Vector u (Solucion): '
print*,

print*,
print*, u
print*,

if (allocated(a)) deallocate(a)

if (allocated(b)) deallocate(b)

if (allocated(u)) deallocate(u)

if(allocated(r)) deallocate(r)

if(allocated(a_copia)) deallocate(a_copia)

end program


module triangle
  implicit none

  interface equilateral
    module procedure equilateral_real
    module procedure equilateral_int
  end interface

  interface scalene
    module procedure scalene_real
    module procedure scalene_int
  end interface

  interface isosceles
    module procedure isosceles_real
    module procedure isosceles_int
  end interface
  real, parameter :: TOL = 1.0E-8

  contains

  logical function intol(a,b)
    real :: a,b
    intol = abs(a-b)<TOL
  end function

  logical function is_triangle_real(edges)
    ! sum of 2 sides > other side
    real,dimension(3) :: edges
    is_triangle_real = sum(edges(1:2))>edges(3) .and. sum(edges(2:3))>edges(1) &
      &  .and. edges(1)+edges(3)>edges(2)
  end function
  logical function is_triangle_int(edges)
    ! sum of 2 sides > other side
    integer,dimension(3) :: edges
    is_triangle_int = sum(edges(1:2))>edges(3) .and. sum(edges(2:3))>edges(1) &
     & .and. edges(1)+edges(3)>edges(2)
  end function

  logical function equilateral_real(edges)
    real,dimension(3) :: edges
    equilateral_real= is_triangle_real(edges) .and. intol(edges(1),edges(2)) &
      & .and. intol(edges(1),edges(3)) .and. .not. intol(edges(1),0.0)
  end function

  logical function equilateral_int(edges)
    integer,dimension(3) :: edges
    equilateral_int=is_triangle_int(edges) .and. edges(1)==edges(2) &
      &  .and.edges(1)==edges(3) .and. edges(1)/=0
  end function

  logical function isosceles_real(edges)
    real,dimension(3) :: edges
    isosceles_real=.false.
    if (equilateral_real(edges))then
      isosceles_real = .true.
      return
    endif
    isosceles_real = is_triangle_real(edges) .and. intol(edges(1),edges(2))  &
      & .or. intol(edges(1),edges(3)) .or. intol(edges(2),edges(3))
  end function

  logical function isosceles_int(edges)
    integer,dimension(3) :: edges
    isosceles_int=.false.
    if (equilateral_int(edges))then
      isosceles_int = .true.
      return
    endif
    isosceles_int =is_triangle_int(edges) .and. (edges(1)==edges(2) &
      & .or. edges(1)==edges(3) .or. edges(2)==edges(3))
  end function

  logical function scalene_real(edges)
    real,dimension(3) :: edges
    scalene_real = is_triangle_real(edges) .and. .not. isosceles(edges) &
      &  .and. .not. equilateral(edges)
  end function

  logical function scalene_int(edges)
    integer,dimension(3) :: edges
    scalene_int = is_triangle_int(edges) .and. .not. isosceles(edges) &
      & .and. .not. equilateral(edges)
  end function

end module


program conjugate_transpose

  complex, dimension(3, 3) :: a
  integer :: i
  a = reshape((/ (i, i=1,9) /), shape(a))
  call characterize(a)
  a(:2,:2) = reshape((/cmplx(3,0),cmplx(2,-1),cmplx(2,1),cmplx(1,0)/),(/2,2/))
  call characterize(a(:2,:2))
  call characterize(cmplx(reshape((/1,0,1,1,1,0,0,1,1/),(/3,3/)),0))
  a(3,:) = (/cmplx(0,0), cmplx(0,0), cmplx(0,1)/)*sqrt(2.0)
  a(2,:) = (/cmplx(0,-1),cmplx(0,1),cmplx(0,0)/)
  a(1,:) = (/1,1,0/)
  a = a * sqrt(2.0)/2.0
  call characterize(a)

contains

  subroutine characterize(a)
    complex, dimension(:,:), intent(in) :: a
    integer :: i, j
    do i=1, size(a,1)
       print *,(a(i, j), j=1,size(a,1))
    end do
    print *,'Is Hermitian?  ',HermitianQ(a)
    print *,'Is normal?  ',NormalQ(a)
    print *,'Unitary?  ',UnitaryQ(a)
    print '(/)'
  end subroutine characterize

  function ct(a) result(b) ! return the conjugate transpose of a matrix
    complex, dimension(:,:), intent(in) :: a
    complex, dimension(size(a,1),size(a,1)) :: b
    b = conjg(transpose(a))
  end function ct

  function identity(n) result(b) ! return identity matrix
    integer, intent(in) :: n
    real, dimension(n,n) :: b
    integer :: i
    b = 0
    do i=1, n
       b(i,i) = 1
    end do
  end function identity

  logical function HermitianQ(a)
    complex, dimension(:,:), intent(in) :: a
    HermitianQ = all(a .eq. ct(a))
  end function HermitianQ

  logical function NormalQ(a)
    complex, dimension(:,:), intent(in) :: a
    NormalQ = all(matmul(ct(a),a) .eq. matmul(a,ct(a)))
  end function NormalQ

  logical function UnitaryQ(a)
    ! if  A inverse equals A star
    ! then multiplying each side by A should result in the identity matrix
    ! Thus show that  A times A star  is sufficiently close to  I .
    complex, dimension(:,:), intent(in) :: a
    UnitaryQ = all(abs(matmul(a,ct(a)) - identity(size(a,1))) .lt. 1e-6)
  end function UnitaryQ

end program conjugate_transpose


	FUNCTION PR_THTA  ( tmpc, pres )
C************************************************************************
C* PR_THTA								*
C*									*
C* This function computes THTA from TMPC and PRES using Poisson's	*
C* equation:								*
C*									*
C*            THTA = TMPK * ( 1000 / PRES ) ** RKAPPA			*
C*									*
C* This function also computes STHA from TMPC and PALT, THTV from	*
C* TVRC and PRES, and THTV from TVRC and PALT.				*
C*									*
C* REAL PR_THTA  ( TMPC, PRES )						*
C*									*
C* Input parameters:							*
C*	TMPC		REAL		Temperature in Celsius		*
C*	PRES		REAL    	Pressure in millibars		*
C*									*
C* Output parameters:							*
C*	PR_THTA		REAL		Potential temperature in K	*
C**									*
C* Log:									*
C* P. Kocin/914		1980	Original source code			*
C* G. Huffman/GSC       8/88    Documentation; check p .le. 0		*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for missing values.
C
	IF  ( ERMISS ( tmpc ) .or. ERMISS ( pres )
     *       .or.  ( pres .le. 0. ) )  THEN
	    PR_THTA = RMISSD
	  ELSE
C
C*	    Change temperature in degrees Celsius to Kelvin.
C
	    tmpk = PR_TMCK( tmpc )
C
C*	    Calculate theta.
C
	    PR_THTA = tmpk * (1000. / pres) ** RKAPPA
	END IF
C*
	RETURN
	END