!> Interfaces to level 3 BLAS routines.
module blas_pure_level3
  use blas_kinds, only : ik, sp, dp
  implicit none
  private

  public :: blas_gemm, blas_hemm, blas_her2k, blas_herk, blas_symm, blas_syr2k, blas_syrk, &
    & blas_trsm, blas_trmm

  !> Performs one of the matrix-matrix operations
  !>
  !>    C := alpha*op( A )*op( B ) + beta*C,
  !>
  !> where  op( X ) is one of
  !>
  !>    op( X ) = X   or   op( X ) = X**T,
  !>
  !> alpha and beta are scalars, and A, B and C are matrices, with op( A )
  !> an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
  interface blas_gemm
    pure subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: transa
      character, intent(in) :: transb
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(in) :: b(ldb, *)
      real(wp), intent(in) :: beta
      real(wp), intent(inout) :: c(ldc, *)
    end subroutine sgemm
    pure subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: transa
      character, intent(in) :: transb
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(in) :: b(ldb, *)
      real(wp), intent(in) :: beta
      real(wp), intent(inout) :: c(ldc, *)
    end subroutine dgemm

    pure subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: transa
      character, intent(in) :: transb
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: b(ldb, *)
      complex(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine cgemm
    pure subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: transa
      character, intent(in) :: transb
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: b(ldb, *)
      complex(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine zgemm

    module procedure :: blas_gemm_rsp
    module procedure :: blas_gemm_csp
    module procedure :: blas_gemm_rdp
    module procedure :: blas_gemm_cdp
  end interface blas_gemm

  interface blas_hemm
    pure subroutine chemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: b(ldb, *)
      complex(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine chemm
    pure subroutine zhemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: b(ldb, *)
      complex(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine zhemm

    module procedure :: blas_hemm_csp
    module procedure :: blas_hemm_cdp
  end interface blas_hemm

  interface blas_her2k
    pure subroutine cher2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: b(ldb, *)
      real(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine cher2k
    pure subroutine zher2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: b(ldb, *)
      real(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine zher2k

    module procedure :: blas_her2k_csp
    module procedure :: blas_her2k_cdp
  end interface blas_her2k

  interface blas_herk
    pure subroutine cherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      real(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      real(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine cherk
    pure subroutine zherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      real(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      real(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine zherk

    module procedure :: blas_herk_csp
    module procedure :: blas_herk_cdp
  end interface blas_herk

  !> Performs one of the matrix-matrix operations
  !>
  !>    C := alpha*A*B + beta*C,
  !>
  !> or
  !>
  !>    C := alpha*B*A + beta*C,
  !>
  !> where alpha and beta are scalars,  A is a symmetric matrix and  B and
  !> C are  m by n matrices.
  interface blas_symm
    pure subroutine ssymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(in) :: b(ldb, *)
      real(wp), intent(in) :: beta
      real(wp), intent(inout) :: c(ldc, *)
    end subroutine ssymm
    pure subroutine dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(in) :: b(ldb, *)
      real(wp), intent(in) :: beta
      real(wp), intent(inout) :: c(ldc, *)
    end subroutine dsymm

    pure subroutine csymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: b(ldb, *)
      complex(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine csymm
    pure subroutine zsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: b(ldb, *)
      complex(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine zsymm

    module procedure :: blas_symm_rsp
    module procedure :: blas_symm_csp
    module procedure :: blas_symm_rdp
    module procedure :: blas_symm_cdp
  end interface blas_symm

  !> Performs one of the symmetric rank 2k operations
  !>
  !>    C := alpha*A*B**T + alpha*B*A**T + beta*C,
  !>
  !> or
  !>
  !>    C := alpha*A**T*B + alpha*B**T*A + beta*C,
  !>
  !> where  alpha and beta  are scalars, C is an  n by n  symmetric matrix
  !> and  A and B  are  n by k  matrices  in the  first  case  and  k by n
  !> matrices in the second case.
  interface blas_syr2k
    pure subroutine ssyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(in) :: b(ldb, *)
      real(wp), intent(in) :: beta
      real(wp), intent(inout) :: c(ldc, *)
    end subroutine ssyr2k
    pure subroutine dsyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(in) :: b(ldb, *)
      real(wp), intent(in) :: beta
      real(wp), intent(inout) :: c(ldc, *)
    end subroutine dsyr2k

    pure subroutine csyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: b(ldb, *)
      complex(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine csyr2k
    pure subroutine zsyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: b(ldb, *)
      complex(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine zsyr2k

    module procedure :: blas_syr2k_rsp
    module procedure :: blas_syr2k_csp
    module procedure :: blas_syr2k_rdp
    module procedure :: blas_syr2k_cdp
  end interface blas_syr2k

  !> Performs one of the symmetric rank k operations
  !>
  !>    C := alpha*A*A**T + beta*C,
  !>
  !> or
  !>
  !>    C := alpha*A**T*A + beta*C,
  !>
  !> where  alpha and beta  are scalars, C is an  n by n  symmetric matrix
  !> and  A  is an  n by k  matrix in the first case and a  k by n  matrix
  !> in the second case.
  interface blas_syrk
    pure subroutine ssyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(in) :: beta
      real(wp), intent(inout) :: c(ldc, *)
    end subroutine ssyrk
    pure subroutine dsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(in) :: beta
      real(wp), intent(inout) :: c(ldc, *)
    end subroutine dsyrk

    pure subroutine csyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine csyrk
    pure subroutine zsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldc
      integer(ik), intent(in) :: lda
      character, intent(in) :: uplo
      character, intent(in) :: trans
      integer(ik), intent(in) :: n
      integer(ik), intent(in) :: k
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(in) :: beta
      complex(wp), intent(inout) :: c(ldc, *)
    end subroutine zsyrk

    module procedure :: blas_syrk_rsp
    module procedure :: blas_syrk_csp
    module procedure :: blas_syrk_rdp
    module procedure :: blas_syrk_cdp
  end interface blas_syrk

  !> Performs one of the matrix-matrix operations
  !>
  !>    B := alpha*op( A )*B,   or   B := alpha*B*op( A ),
  !>
  !> where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
  !> non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
  !>
  !>    op( A ) = A   or   op( A ) = A**T.
  interface blas_trmm
    pure subroutine strmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      character, intent(in) :: transa
      character, intent(in) :: diag
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(inout) :: b(ldb, *)
    end subroutine strmm
    pure subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      character, intent(in) :: transa
      character, intent(in) :: diag
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(inout) :: b(ldb, *)
    end subroutine dtrmm

    pure subroutine ctrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      character, intent(in) :: transa
      character, intent(in) :: diag
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(inout) :: b(ldb, *)
    end subroutine ctrmm
    pure subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      character, intent(in) :: transa
      character, intent(in) :: diag
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(inout) :: b(ldb, *)
    end subroutine ztrmm

    module procedure :: blas_trmm_rsp
    module procedure :: blas_trmm_csp
    module procedure :: blas_trmm_rdp
    module procedure :: blas_trmm_cdp
  end interface blas_trmm

  !> Solves one of the matrix equations
  !>
  !>    op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
  !>
  !> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
  !> non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
  !>
  !>    op( A ) = A   or   op( A ) = A**T.
  !>
  !> The matrix X is overwritten on B.
  interface blas_trsm
    pure subroutine strsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      character, intent(in) :: transa
      character, intent(in) :: diag
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(inout) :: b(ldb, *)
    end subroutine strsm
    pure subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      character, intent(in) :: transa
      character, intent(in) :: diag
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      real(wp), intent(in) :: alpha
      real(wp), intent(in) :: a(lda, *)
      real(wp), intent(inout) :: b(ldb, *)
    end subroutine dtrsm

    pure subroutine ctrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, sp
      integer, parameter :: wp = sp
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      character, intent(in) :: transa
      character, intent(in) :: diag
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(inout) :: b(ldb, *)
    end subroutine ctrsm
    pure subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, dp
      integer, parameter :: wp = dp
      integer(ik), intent(in) :: ldb
      integer(ik), intent(in) :: lda
      character, intent(in) :: side
      character, intent(in) :: uplo
      character, intent(in) :: transa
      character, intent(in) :: diag
      integer(ik), intent(in) :: m
      integer(ik), intent(in) :: n
      complex(wp), intent(in) :: alpha
      complex(wp), intent(in) :: a(lda, *)
      complex(wp), intent(inout) :: b(ldb, *)
    end subroutine ztrsm

    module procedure :: blas_trsm_rsp
    module procedure :: blas_trsm_csp
    module procedure :: blas_trsm_rdp
    module procedure :: blas_trsm_cdp
  end interface blas_trsm

contains

  pure subroutine blas_gemm_rsp(amat, bmat, cmat, transa, transb, alpha, beta)
    integer, parameter :: wp = sp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(in) :: bmat(:, :)
    real(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: transa
    character, intent(in), optional :: transb
    real(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: tra, trb
    real(wp) :: a, b
    integer(ik) :: m, n, k, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(transa)) tra = transa
    trb = 'n'
    if (present(transb)) trb = transb
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    m = size(cmat, 1)
    n = size(cmat, 2)
    call blas_gemm(tra, trb, m, n, k, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_gemm_rsp

  pure subroutine blas_gemm_csp(amat, bmat, cmat, transa, transb, alpha, beta)
    integer, parameter :: wp = sp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(in) :: bmat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: transa
    character, intent(in), optional :: transb
    complex(wp), intent(in), optional :: alpha
    complex(wp), intent(in), optional :: beta

    character :: tra, trb
    complex(wp) :: a, b
    integer(ik) :: m, n, k, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(transa)) tra = transa
    trb = 'n'
    if (present(transb)) trb = transb
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    m = size(cmat, 1)
    n = size(cmat, 2)
    call blas_gemm(tra, trb, m, n, k, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_gemm_csp

  pure subroutine blas_gemm_rdp(amat, bmat, cmat, transa, transb, alpha, beta)
    integer, parameter :: wp = dp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(in) :: bmat(:, :)
    real(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: transa
    character, intent(in), optional :: transb
    real(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: tra, trb
    real(wp) :: a, b
    integer(ik) :: m, n, k, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(transa)) tra = transa
    trb = 'n'
    if (present(transb)) trb = transb
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    m = size(cmat, 1)
    n = size(cmat, 2)
    call blas_gemm(tra, trb, m, n, k, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_gemm_rdp

  pure subroutine blas_gemm_cdp(amat, bmat, cmat, transa, transb, alpha, beta)
    integer, parameter :: wp = dp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(in) :: bmat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: transa
    character, intent(in), optional :: transb
    complex(wp), intent(in), optional :: alpha
    complex(wp), intent(in), optional :: beta

    character :: tra, trb
    complex(wp) :: a, b
    integer(ik) :: m, n, k, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(transa)) tra = transa
    trb = 'n'
    if (present(transb)) trb = transb
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    m = size(cmat, 1)
    n = size(cmat, 2)
    call blas_gemm(tra, trb, m, n, k, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_gemm_cdp

  pure subroutine blas_symm_rsp(amat, bmat, cmat, side, uplo, alpha, beta)
    integer, parameter :: wp = sp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(in) :: bmat(:, :)
    real(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    real(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: lra, ula
    real(wp) :: a, b
    integer(ik) :: m, n, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    lra = 'l'
    if (present(side)) lra = side
    ula = 'u'
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    m = size(cmat, 1)
    n = size(cmat, 2)
    call blas_symm(lra, ula, m, n, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_symm_rsp

  pure subroutine blas_symm_csp(amat, bmat, cmat, side, uplo, alpha, beta)
    integer, parameter :: wp = sp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(in) :: bmat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    complex(wp), intent(in), optional :: alpha
    complex(wp), intent(in), optional :: beta

    character :: lra, ula
    complex(wp) :: a, b
    integer(ik) :: m, n, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    lra = 'l'
    if (present(side)) lra = side
    ula = 'u'
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    m = size(cmat, 1)
    n = size(cmat, 2)
    call blas_symm(lra, ula, m, n, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_symm_csp

  pure subroutine blas_hemm_csp(amat, bmat, cmat, side, uplo, alpha, beta)
    integer, parameter :: wp = sp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(in) :: bmat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    complex(wp), intent(in), optional :: alpha
    complex(wp), intent(in), optional :: beta

    character :: lra, ula
    complex(wp) :: a, b
    integer(ik) :: m, n, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    lra = 'l'
    if (present(side)) lra = side
    ula = 'u'
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    m = size(cmat, 1)
    n = size(cmat, 2)
    call blas_hemm(lra, ula, m, n, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_hemm_csp

  pure subroutine blas_symm_rdp(amat, bmat, cmat, side, uplo, alpha, beta)
    integer, parameter :: wp = dp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(in) :: bmat(:, :)
    real(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    real(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: lra, ula
    real(wp) :: a, b
    integer(ik) :: m, n, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    lra = 'l'
    if (present(side)) lra = side
    ula = 'u'
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    m = size(cmat, 1)
    n = size(cmat, 2)
    call blas_symm(lra, ula, m, n, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_symm_rdp

  pure subroutine blas_symm_cdp(amat, bmat, cmat, side, uplo, alpha, beta)
    integer, parameter :: wp = dp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(in) :: bmat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    complex(wp), intent(in), optional :: alpha
    complex(wp), intent(in), optional :: beta

    character :: lra, ula
    complex(wp) :: a, b
    integer(ik) :: m, n, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    lra = 'l'
    if (present(side)) lra = side
    ula = 'u'
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    m = size(cmat, 1)
    n = size(cmat, 2)
    call blas_symm(lra, ula, m, n, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_symm_cdp

  pure subroutine blas_hemm_cdp(amat, bmat, cmat, side, uplo, alpha, beta)
    integer, parameter :: wp = dp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(in) :: bmat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    complex(wp), intent(in), optional :: alpha
    complex(wp), intent(in), optional :: beta

    character :: lra, ula
    complex(wp) :: a, b
    integer(ik) :: m, n, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    lra = 'l'
    if (present(side)) lra = side
    ula = 'u'
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    m = size(cmat, 1)
    n = size(cmat, 2)
    call blas_hemm(lra, ula, m, n, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_hemm_cdp

  pure subroutine blas_syrk_rsp(amat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = sp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    real(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: ula, tra
    real(wp) :: a, b
    integer(ik) :: n, k, lda, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_syrk(ula, tra, n, k, a, amat, lda, b, cmat, ldc)
  end subroutine blas_syrk_rsp

  pure subroutine blas_syrk_csp(amat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = sp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    complex(wp), intent(in), optional :: alpha
    complex(wp), intent(in), optional :: beta

    character :: ula, tra
    complex(wp) :: a, b
    integer(ik) :: n, k, lda, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_syrk(ula, tra, n, k, a, amat, lda, b, cmat, ldc)
  end subroutine blas_syrk_csp

  pure subroutine blas_herk_csp(amat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = sp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    real(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: ula, tra
    real(wp) :: a, b
    integer(ik) :: n, k, lda, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_herk(ula, tra, n, k, a, amat, lda, b, cmat, ldc)
  end subroutine blas_herk_csp

  pure subroutine blas_syrk_rdp(amat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = dp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    real(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: ula, tra
    real(wp) :: a, b
    integer(ik) :: n, k, lda, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_syrk(ula, tra, n, k, a, amat, lda, b, cmat, ldc)
  end subroutine blas_syrk_rdp

  pure subroutine blas_syrk_cdp(amat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = dp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    complex(wp), intent(in), optional :: alpha
    complex(wp), intent(in), optional :: beta

    character :: ula, tra
    complex(wp) :: a, b
    integer(ik) :: n, k, lda, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_syrk(ula, tra, n, k, a, amat, lda, b, cmat, ldc)
  end subroutine blas_syrk_cdp

  pure subroutine blas_herk_cdp(amat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = dp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    real(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: ula, tra
    real(wp) :: a, b
    integer(ik) :: n, k, lda, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_herk(ula, tra, n, k, a, amat, lda, b, cmat, ldc)
  end subroutine blas_herk_cdp

  pure subroutine blas_syr2k_rsp(amat, bmat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = sp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(in) :: bmat(:, :)
    real(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    real(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: ula, tra
    real(wp) :: a, b
    integer(ik) :: n, k, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_syr2k(ula, tra, n, k, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_syr2k_rsp

  pure subroutine blas_syr2k_csp(amat, bmat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = sp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(in) :: bmat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    complex(wp), intent(in), optional :: alpha
    complex(wp), intent(in), optional :: beta

    character :: ula, tra
    complex(wp) :: a, b
    integer(ik) :: n, k, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_syr2k(ula, tra, n, k, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_syr2k_csp

  pure subroutine blas_her2k_csp(amat, bmat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = sp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(in) :: bmat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    complex(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: ula, tra
    complex(wp) :: a
    real(wp) :: b
    integer(ik) :: n, k, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_her2k(ula, tra, n, k, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_her2k_csp

  pure subroutine blas_syr2k_rdp(amat, bmat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = dp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(in) :: bmat(:, :)
    real(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    real(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: ula, tra
    real(wp) :: a, b
    integer(ik) :: n, k, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_syr2k(ula, tra, n, k, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_syr2k_rdp

  pure subroutine blas_syr2k_cdp(amat, bmat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = dp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(in) :: bmat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    complex(wp), intent(in), optional :: alpha
    complex(wp), intent(in), optional :: beta

    character :: ula, tra
    complex(wp) :: a, b
    integer(ik) :: n, k, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_syr2k(ula, tra, n, k, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_syr2k_cdp

  pure subroutine blas_her2k_cdp(amat, bmat, cmat, uplo, trans, alpha, beta)
    integer, parameter :: wp = dp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(in) :: bmat(:, :)
    complex(wp), contiguous, intent(inout) :: cmat(:, :)
    character, intent(in), optional :: uplo
    character, intent(in), optional :: trans
    complex(wp), intent(in), optional :: alpha
    real(wp), intent(in), optional :: beta

    character :: ula, tra
    complex(wp) :: a
    real(wp) :: b
    integer(ik) :: n, k, lda, ldb, ldc

    a = 1.0_wp
    if (present(alpha)) a = alpha
    b = 0.0_wp
    if (present(beta)) b = beta
    tra = 'n'
    if (present(trans)) tra = trans
    ula = 'u'
    if (present(uplo)) ula = uplo
    if ((tra == 'n'.or.tra == 'N')) then
      k = size(amat, 2)
    else
      k = size(amat, 1)
    end if
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    ldc = max(1, size(cmat, 1))
    n = size(cmat, 2)
    call blas_her2k(ula, tra, n, k, a, amat, lda, bmat, ldb, b, cmat, ldc)
  end subroutine blas_her2k_cdp

  pure subroutine blas_trsm_rsp(amat, bmat, side, uplo, transa, diag, alpha)
    integer, parameter :: wp = sp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(inout) :: bmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    character, intent(in), optional :: transa
    character, intent(in), optional :: diag
    real(wp), intent(in), optional :: alpha

    character :: lra, ula, tra, dia
    real(wp) :: a
    integer(ik) :: m, n, lda, ldb

    a = 1.0_wp
    dia = 'n'
    lra = 'l'
    tra = 'n'
    ula = 'u'
    if (present(alpha)) a = alpha
    if (present(diag)) dia = diag
    if (present(side)) lra = side
    if (present(transa)) tra = transa
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    m = size(bmat, 1)
    n = size(bmat, 2)
    call blas_trsm(lra, ula, tra, dia, m, n, a, amat, lda, bmat, ldb)
  end subroutine blas_trsm_rsp

  pure subroutine blas_trsm_csp(amat, bmat, side, uplo, transa, diag, alpha)
    integer, parameter :: wp = sp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(inout) :: bmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    character, intent(in), optional :: transa
    character, intent(in), optional :: diag
    complex(wp), intent(in), optional :: alpha

    character :: lra, ula, tra, dia
    complex(wp) :: a
    integer(ik) :: m, n, lda, ldb

    a = 1.0_wp
    dia = 'n'
    lra = 'l'
    tra = 'n'
    ula = 'u'
    if (present(alpha)) a = alpha
    if (present(diag)) dia = diag
    if (present(side)) lra = side
    if (present(transa)) tra = transa
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    m = size(bmat, 1)
    n = size(bmat, 2)
    call blas_trsm(lra, ula, tra, dia, m, n, a, amat, lda, bmat, ldb)
  end subroutine blas_trsm_csp

  pure subroutine blas_trsm_rdp(amat, bmat, side, uplo, transa, diag, alpha)
    integer, parameter :: wp = dp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(inout) :: bmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    character, intent(in), optional :: transa
    character, intent(in), optional :: diag
    real(wp), intent(in), optional :: alpha

    character :: lra, ula, tra, dia
    real(wp) :: a
    integer(ik) :: m, n, lda, ldb

    a = 1.0_wp
    dia = 'n'
    lra = 'l'
    tra = 'n'
    ula = 'u'
    if (present(alpha)) a = alpha
    if (present(diag)) dia = diag
    if (present(side)) lra = side
    if (present(transa)) tra = transa
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    m = size(bmat, 1)
    n = size(bmat, 2)
    call blas_trsm(lra, ula, tra, dia, m, n, a, amat, lda, bmat, ldb)
  end subroutine blas_trsm_rdp

  pure subroutine blas_trsm_cdp(amat, bmat, side, uplo, transa, diag, alpha)
    integer, parameter :: wp = dp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(inout) :: bmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    character, intent(in), optional :: transa
    character, intent(in), optional :: diag
    complex(wp), intent(in), optional :: alpha

    character :: lra, ula, tra, dia
    complex(wp) :: a
    integer(ik) :: m, n, lda, ldb

    a = 1.0_wp
    dia = 'n'
    lra = 'l'
    tra = 'n'
    ula = 'u'
    if (present(alpha)) a = alpha
    if (present(diag)) dia = diag
    if (present(side)) lra = side
    if (present(transa)) tra = transa
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    m = size(bmat, 1)
    n = size(bmat, 2)
    call blas_trsm(lra, ula, tra, dia, m, n, a, amat, lda, bmat, ldb)
  end subroutine blas_trsm_cdp

  pure subroutine blas_trmm_rsp(amat, bmat, side, uplo, transa, diag, alpha)
    integer, parameter :: wp = sp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(inout) :: bmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    character, intent(in), optional :: transa
    character, intent(in), optional :: diag
    real(wp), intent(in), optional :: alpha

    character :: lra, ula, tra, dia
    real(wp) :: a
    integer(ik) :: m, n, lda, ldb

    a = 1.0_wp
    dia = 'n'
    lra = 'l'
    tra = 'n'
    ula = 'u'
    if (present(alpha)) a = alpha
    if (present(diag)) dia = diag
    if (present(side)) lra = side
    if (present(transa)) tra = transa
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    m = size(bmat, 1)
    n = size(bmat, 2)
    call blas_trmm(lra, ula, tra, dia, m, n, a, amat, lda, bmat, ldb)
  end subroutine blas_trmm_rsp

  pure subroutine blas_trmm_csp(amat, bmat, side, uplo, transa, diag, alpha)
    integer, parameter :: wp = sp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(inout) :: bmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    character, intent(in), optional :: transa
    character, intent(in), optional :: diag
    complex(wp), intent(in), optional :: alpha

    character :: lra, ula, tra, dia
    complex(wp) :: a
    integer(ik) :: m, n, lda, ldb

    a = 1.0_wp
    dia = 'n'
    lra = 'l'
    tra = 'n'
    ula = 'u'
    if (present(alpha)) a = alpha
    if (present(diag)) dia = diag
    if (present(side)) lra = side
    if (present(transa)) tra = transa
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    m = size(bmat, 1)
    n = size(bmat, 2)
    call blas_trmm(lra, ula, tra, dia, m, n, a, amat, lda, bmat, ldb)
  end subroutine blas_trmm_csp

  pure subroutine blas_trmm_rdp(amat, bmat, side, uplo, transa, diag, alpha)
    integer, parameter :: wp = dp
    real(wp), contiguous, intent(in) :: amat(:, :)
    real(wp), contiguous, intent(inout) :: bmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    character, intent(in), optional :: transa
    character, intent(in), optional :: diag
    real(wp), intent(in), optional :: alpha

    character :: lra, ula, tra, dia
    real(wp) :: a
    integer(ik) :: m, n, lda, ldb

    a = 1.0_wp
    dia = 'n'
    lra = 'l'
    tra = 'n'
    ula = 'u'
    if (present(alpha)) a = alpha
    if (present(diag)) dia = diag
    if (present(side)) lra = side
    if (present(transa)) tra = transa
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    m = size(bmat, 1)
    n = size(bmat, 2)
    call blas_trmm(lra, ula, tra, dia, m, n, a, amat, lda, bmat, ldb)
  end subroutine blas_trmm_rdp

  pure subroutine blas_trmm_cdp(amat, bmat, side, uplo, transa, diag, alpha)
    integer, parameter :: wp = dp
    complex(wp), contiguous, intent(in) :: amat(:, :)
    complex(wp), contiguous, intent(inout) :: bmat(:, :)
    character, intent(in), optional :: side
    character, intent(in), optional :: uplo
    character, intent(in), optional :: transa
    character, intent(in), optional :: diag
    complex(wp), intent(in), optional :: alpha

    character :: lra, ula, tra, dia
    complex(wp) :: a
    integer(ik) :: m, n, lda, ldb

    a = 1.0_wp
    dia = 'n'
    lra = 'l'
    tra = 'n'
    ula = 'u'
    if (present(alpha)) a = alpha
    if (present(diag)) dia = diag
    if (present(side)) lra = side
    if (present(transa)) tra = transa
    if (present(uplo)) ula = uplo
    lda = max(1, size(amat, 1))
    ldb = max(1, size(bmat, 1))
    m = size(bmat, 1)
    n = size(bmat, 2)
    call blas_trmm(lra, ula, tra, dia, m, n, a, amat, lda, bmat, ldb)
  end subroutine blas_trmm_cdp

end module blas_pure_level3


      PROGRAM MWSPEC
c
c  computes power spectrum of a real data sequence using
c  multiple prolate window eigenfunction expansion
c
c  calls input,arfilt,rtpss,pssev,eigenft,ftest,mdfd,linefind,reshape,
c        adaptwt,adaptwtl,sft,compos
c
c*************************************************************
c
      parameter (MXDATA=5000,MXLIN=100,MXSPEC=14,MARF=50)
      parameter (MXFREQ=2*MXDATA,MXFREQ2=MXFREQ/2+1)
      parameter (MWSPACE=9*MXDATA+3*MXSPEC+MXDATA*MXSPEC/2+11)
      character prompt*80
      character filnam*80,form*1
      double precision evalu,evalu1,dpss,bw,atol,rtol,arf,om,
     $                 PI,TPI,ct,st,sum
      logical ljack
      complex yk,xmul
      dimension yk(MXFREQ,MXSPEC),xmul(MXLIN),
     $          data(MXDATA),arf(MARF),evalu(MXSPEC),
     $          evalu1(MXSPEC),dpss(MXDATA,MXSPEC),work(MWSPACE),
     $          wsave(4*MXFREQ+15),freql(MXLIN),
     $          freqf(MXFREQ2),f(MXFREQ2),p(MXFREQ2),
     $          flo(MXLIN),fup(MXLIN),iwork(10*MXLIN),
     $          ilin(MXLIN),slin(MXLIN,MXSPEC),spec(MXFREQ2),
     $          se(MXFREQ2),wt(MXFREQ2,MXSPEC),
     $          errsp(MXFREQ2),specl(MXLIN),sel(MXLIN),
     $          wtl(MXLIN,MXSPEC),errspl(MXLIN),
     $          upw(MXFREQ2)
      parameter (PI=3.141592653589793d0,TPI=2.*PI,deg=180./PI)
      data ljack/.true./
      data form/'f'/
c***************************************************************
c   set up data vector
      write(6,1)
    1 format(' input the data filename:',$)
      read(5,2)filnam
    2 format(a)
      write(6,5)
    5 format(' input the number of data points to skip and read:',$)
      read(5,*)nskip,npts
      call input(filnam,form,nblock,nskip,npts,data)
      write(6,*)npts,' data values input'
      if(npts.gt.MXDATA)then
        write(6,*)' fatal error-too many data values input'
        stop
      endif
      prompt(1:80)='input the ar filter length (0 for none)'
      nar = iask(prompt,0)
c      write(6,6)
c    6 format(' input the ar filter length (0 for none):',$)
c      read(5,*)nar
      if(nar.gt.0)then
        call arfilt(npts,nar,data,work(nar+2),work)
        do 7 i=1,nar
    7     arf(i)=work(i)
      endif
c  **************************************************************
c   input spectrum parameters
c
      ntemp = 2*npts
      prompt(1:80) = 'input the fft length'
      nfft = iask(prompt,ntemp)
c      write(6,11)
c   11 format(' input the fft length:',$)
c      read(5,*)nfft
c  force fft length to even number of values
      if(mod(nfft,2).ne.0)nfft=nfft+1
c  force fft length to at least twice npts to avoid circular
c  convolutions
      if(nfft.lt.2*npts)then
        nfft=2*npts
        write(6,*)' fft length increased to ',nfft
      endif
      rtemp = 4.
      prompt(1:80) = 'input the time-bandwidth product'
      tbw = rask(prompt,rtemp)
c      write(6,12)
c   12 format(' input the time-bandwidth product:',$)
c      read(5,*)tbw
      ntemp = 2.*tbw - 1.
      prompt(1:80) = 'input the number of eigenspectra'
      kspec = iask(prompt,ntemp)
c      write(6,13)
c   13 format(' input the number of eigenspectra:',$)
c      read(5,*)kspec
      if((kspec.gt.2.*tbw).or.(kspec.gt.MXSPEC))then
        kspec=min(int(2.*tbw),MXSPEC)
        write(6,*)' number of spectra reduced to',kspec
      endif
      xnpts=npts
      xnfft=nfft
      xkspec=kspec
      nfft2=nfft/2
      nyq=nfft2+1
      bw=tbw/xnpts
      do 15 i=1,nyq
   15   freqf(i)=float(i-1)/xnfft
c  ***************************************************************
c
c  compute kspec discrete prolate spheroidal sequences for use as
c  data windows along with the associated eigenvalues
      rtol=1.d-8
      atol=1.d-14
      call rtpss(MXDATA,npts,kspec,bw,dpss,evalu1,iflag,work)
      call pssev(MXDATA,npts,kspec,bw,rtol,atol,dpss,evalu,evalu1)
      if(iflag.ne.0)then
        write(6,*)' fatal error while computing dpss  iflag=',iflag
        stop
      endif
c  compute estimate of variance efficiency
      xi=0.
      do 20 i=1,npts
        sum=0.
        do 19 j=1,kspec
   19     sum=sum+dpss(i,j)**2
        sum=sum/kspec
   20   xi=xi+sum**2
      xi=1./(xnpts*xi)
c
c calculate eigen-ft's yk using prolate windows dpss
c
      call eigenft(npts,nfft,kspec,data,MXDATA,dpss,
     $             wsave,MXFREQ,yk)
c
c  compute f-test for spectral line components and probabilities
c  corresponding to f
c
      pc=max(0.9,(xnpts-10.)/xnpts)
      write(6,26)pc
   26 format(' critical probability level=',g15.7)
      call ftest(npts,nyq,kspec,MXDATA,dpss,MXFREQ,yk,work,f)
      write(6,30)
   30 format(' input the f-test filename:',$)
      read(5,2)filnam
      open (unit=10,file=filnam,status='new')
      kl=0
      do 35 i=1,nyq
        call mdfd(f(i),2,2*(kspec-1),p(i),ier)
        write(10,900)freqf(i),f(i),p(i)
        if(p(i).ge.pc)then
          if(kl.eq.0)write(6,37)
          write(6,900)freqf(i),f(i),p(i)
          kl=1
        endif
   35   continue
      if(kl.eq.0)write(6,*)' no significant lines detected'
   37 format(4x,'frequency',5x,'f-statistic',4x,'probability')
      close (unit=10)
      pctemp = 1.
      prompt(1:80)='input critical probability for reshaping'
      prompt(42:80)='(1.0 for none)'
      pc = rask(prompt,pctemp)
c      write(6,41)
c   41 format(' input the critical probability for reshaping:',$)
c      read(5,*)pc
      if(pc.eq.1.)then
        nl=0
        goto 70
      endif
      write(6,43)
   43 format(' input the lower and upper frequency bounds (nyq)')
      nf=0
      do 50 i=1,MXLIN
        read(5,*,end=51)flo(i),fup(i)
        if(fup(i).eq.999.)then
          goto 51
        elseif(fup(i).eq..5)then
          nf=nf+1
          goto 51
        else
          nf=nf+1
        endif
   50   continue
   51 continue
c
c  find line parameters for all significant lines
c  reshape eigenspectra around significant spectral lines
c
      call linefind(npts,nfft,kspec,MXLIN,nf,flo,fup,pc,p,
     $              MXDATA,dpss,MXFREQ,yk,iwork,work,nl,
     $              xmul,ilin)
      if(nl.gt.0)then
c  add negative frequency terms for reshaping
        nll=nl
        do 55 i=1,nl
          if((ilin(i).eq.1).or.(ilin(i).eq.nyq))goto 55
          nll=nll+1
          ilin(nll)=nfft-ilin(i)+2
          xmul(nll)=conjg(xmul(i))
   55     continue
        call reshape(npts,nfft,kspec,nll,MXDATA,dpss,ilin,
     $               xmul,MXFREQ,yk,wsave,work,MXLIN,slin)
      endif
      do 58 i=1,nl
   58   freql(i)=float(ilin(i)-1)/xnfft
c
c  compute adaptively weighted spectrum
c
   70 continue
      write(6,71)xi
   71 format(' variance efficiency=',g15.7)
      sum=0.
      do 72 i=1,npts
   72   sum=sum+data(i)**2
      dvar=sum/xnpts
      call adaptwt(nfft,nyq,kspec,dvar,evalu1,MXFREQ,yk,
     $             work,MXFREQ2,spec,se,wt,errsp,ljack)
c  double power in positive frequencies
      do 74 i=2,nfft2
   74   spec(i)=2.*spec(i)
      if(nll.gt.0)then
        call adaptwtl(nfft,nll,kspec,dvar,evalu1,ilin,MXLIN,
     $                slin,work,specl,sel,wtl,errspl)
        no=nll
        do 75 i=1,nll
   75     if((ilin(i).eq.1).or.(ilin(i).eq.nyq))no=no-1
        no=no/2
        do 76 i=1,nl
   76     if((ilin(i).ne.1).and.(ilin(i).ne.nyq))specl(i)=
     $                                           specl(i)+specl(i+no)
      endif
c  scale spectrum to meet parseval's theorem
      sum=0.
      do 77 i=1,nyq
   77   sum=sum+spec(i)
      do 78 i=1,nl
   78   sum=sum+specl(i)
      sscal=xnfft*dvar/sum
      do 79 i=1,nyq
   79   spec(i)=sscal*spec(i)
      do 80 i=1,nl
   80   specl(i)=sscal*specl(i)
      seavg=0.
      do 85 i=1,nyq
   85   seavg=seavg+se(i)
      do 86 i=1,nl
   86   seavg=seavg+sel(i)
      seavg=seavg/(2.*xkspec*(nyq+nl))
      write(6,91)seavg
   91 format(' average stability of estimate=',g15.7)
      if(nar.gt.0)then
        do 95 i=1,nyq
          om=TPI*freqf(i)
          call sft(arf,nar,om,ct,st)
   95     upw(i)=1./(ct**2+st**2)
      else
        do 96 i=1,nyq
   96     upw(i)=1.
      endif
      write(6,97)
   97 format(' input the averaged spectrum filename:',$)
      read(5,2)filnam
      open (unit=10,file=filnam,status='new')
      k=1
      do 98 i=1,nyq
        if((nl.ne.0).and.(freql(k).eq.freqf(i)))then
          write(10,900)freql(k),upw(i)*specl(k),sel(k),
     $                 upw(i)*specl(k)/errspl(k),
     $                 upw(i)*specl(k)*errspl(k)
          k=k+1
        endif
   98   write(10,900)freqf(i),upw(i)*spec(i),se(i),
     $               upw(i)*spec(i)/errsp(i),
     $               upw(i)*spec(i)*errsp(i)
      close(unit=10)
  900 format(x,5g15.7)
      stop
      end

c $Id$


*DECK ORTHES
      SUBROUTINE ORTHES (NM, N, LOW, IGH, A, ORT)
C***BEGIN PROLOGUE  ORTHES
C***PURPOSE  Reduce a real general matrix to upper Hessenberg form
C            using orthogonal similarity transformations.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B2
C***TYPE      SINGLE PRECISION (ORTHES-S, CORTH-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure ORTHES,
C     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     Given a REAL GENERAL matrix, this subroutine
C     reduces a submatrix situated in rows and columns
C     LOW through IGH to upper Hessenberg form by
C     orthogonal similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, A, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  BALANC.  If  BALANC  has not been
C          used, set LOW=1 and IGH equal to the order of the matrix, N.
C
C        A contains the general matrix to be reduced to upper
C          Hessenberg form.  A is a two-dimensional REAL array,
C          dimensioned A(NM,N).
C
C     On OUTPUT
C
C        A contains the upper Hessenberg matrix.  Some information about
C          the orthogonal transformations used in the reduction
C          is stored in the remaining triangle under the Hessenberg
C          matrix.
C
C        ORT contains further information about the orthogonal trans-
C          formations used in the reduction.  Only elements LOW+1
C          through IGH are used.  ORT is a one-dimensional REAL array,
C          dimensioned ORT(IGH).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  ORTHES
C
      INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
      REAL A(NM,*),ORT(*)
      REAL F,G,H,SCALE
C
C***FIRST EXECUTABLE STATEMENT  ORTHES
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         H = 0.0E0
         ORT(M) = 0.0E0
         SCALE = 0.0E0
C     .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
         DO 90 I = M, IGH
   90    SCALE = SCALE + ABS(A(I,M-1))
C
         IF (SCALE .EQ. 0.0E0) GO TO 180
         MP = M + IGH
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
         DO 100 II = M, IGH
            I = MP - II
            ORT(I) = A(I,M-1) / SCALE
            H = H + ORT(I) * ORT(I)
  100    CONTINUE
C
         G = -SIGN(SQRT(H),ORT(M))
         H = H - ORT(M) * G
         ORT(M) = ORT(M) - G
C     .......... FORM (I-(U*UT)/H) * A ..........
         DO 130 J = M, N
            F = 0.0E0
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
            DO 110 II = M, IGH
               I = MP - II
               F = F + ORT(I) * A(I,J)
  110       CONTINUE
C
            F = F / H
C
            DO 120 I = M, IGH
  120       A(I,J) = A(I,J) - F * ORT(I)
C
  130    CONTINUE
C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
         DO 160 I = 1, IGH
            F = 0.0E0
C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
            DO 140 JJ = M, IGH
               J = MP - JJ
               F = F + ORT(J) * A(I,J)
  140       CONTINUE
C
            F = F / H
C
            DO 150 J = M, IGH
  150       A(I,J) = A(I,J) - F * ORT(J)
C
  160    CONTINUE
C
         ORT(M) = SCALE * ORT(M)
         A(M,M-1) = SCALE * G
  180 CONTINUE
C
  200 RETURN
      END


MODULE ClassVelocidadeU

   USE ClassArrayFonteComplementosU
   USE ClassMatrizA

   ! Modulo que implementa a classe para a velocidade U

   IMPLICIT  NONE

   PRIVATE

   TYPE, PUBLIC :: VelocidadeU

      ! Atritubos Externos serao atualizados por outra rotina
      ! Atributos Internos serao atualizados na classe

      !---------Atributos Externos-----------------------
      INTEGER           :: Tn                                            ! Numero de passos de tempo resolvidos em paralelo
      INTEGER           :: Nx, Ny                                      ! Nx e Ny da malha
      DOUBLE PRECISION  :: Lx, Ly                                      ! Comprimento do dominio
      DOUBLE PRECISION  :: ht                                          ! Refinamento temporal (necessario por causa dos coeficientes)
      DOUBLE PRECISION  :: Re                                          ! Numero de Reynolds (necessario por causa dos coeficientes)
      DOUBLE PRECISION  :: Tolerancia                                  ! Tolerancia no criterio de parada dos solvers
      !--------------------------------------------------

      !--------Atributos Internos------------------------
      DOUBLE PRECISION                                 :: hx, hy       ! hx e hy da malha

      ! ATENCAO: DEFINIR UMA VETOR DE VETORES E RESERVAR VARIAVEIS u0, u1, u2, u3, ..., ut dinamicamente (de acordo com o a ordem do metodo de projecao no futuro)
      DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE      :: u          ! Vetores da velocidade U
      DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE      :: u_bp, u_ex, residuo         ! Vetores da velocidade U
      DOUBLE PRECISION, DIMENSION(:),    ALLOCATABLE      :: u_ref
      DOUBLE PRECISION, DIMENSION(:),    ALLOCATABLE      :: normas_L2

      ! A matriz A de U
      TYPE ( MatrizA ) :: A

      TYPE (ArrayFonteComplementosU), DIMENSION(9) :: FonteComplementosU
      !--------------------------------------------------

      CONTAINS

         ! Metodos da Classe
         procedure :: init                    ! Metodo que inicia a classe
         procedure :: calcula_termo_fonte       !
         procedure :: aplica_condicao_inicial !
         procedure :: single_grid              !
         procedure :: calcula_residuo
         procedure :: calcula_norma_L2
         procedure :: escreve_matriz
         procedure :: escreve_comparacao

   END TYPE VelocidadeU

   CONTAINS

      SUBROUTINE init(self, Nx, Ny, Tn, Lx, Ly, ht, Re, Tolerancia)

         USE Subrotinas_MG_GS

         !------------ Metodo que inicia as variaveis gerais da malha ---------------------

         CLASS( VelocidadeU ), INTENT(INOUT) :: self

         INTEGER         , INTENT(IN)      :: Nx, Ny, Tn
         DOUBLE PRECISION, INTENT(IN)      :: Lx, Ly, ht, Re, Tolerancia

         INTEGER :: st

         ! Atualiando os atributos da classe
         self % Tn = Tn
         self % Lx = Lx
         self % Ly = Ly
         self % Re = Re
         self % ht = ht
         self % Tolerancia = Tolerancia

         ! Calculando hx e hy (o mesmo valor para u, v e p)
         self % hx = self % Lx / Nx
         self % hy = self % Ly / Ny

         ! Atencao: Nx e Ny depende do tipo de variavel considerada (u, v ou p)
         ! entao aqui sera "corrigido" Nx e Ny para a velocidade U
         ! Apos esta correcao vai aparecer no codigo self % Nx e self % Ny (corrigidos) e nao
         ! Nx-1 e Ny
         self % Nx = Nx - 1
         self % Ny = Ny

         ! Reservando os vetores u0, u1, ut
         ! Lembrando que a dimensao real e u0( (Nx-1)*Ny )
         ALLOCATE( self % u   ( self % Nx * self % Ny, self % Tn ), &
                   self % u_bp( self % Nx * self % Ny, self % Tn ), &
                   self % u_ex( self % Nx * self % Ny, self % Tn ), &
                   self % residuo( self % Nx * self % Ny, self % Tn ), &
                   self % normas_L2( self % Tn ), &
                   self % u_ref( self % Nx * self % Ny ) )

         ! Iniciando os vetores
         self % u   (:, :) = 0.0d0
         self % u_bp(:, :) = 0.0d0
         self % u_ex(:, :) = 0.0d0
         self % u_ref(:) = 0.0d0
         self % residuo(:, :) = 0.0d0
         self % normas_L2(:) = 0.0d0

         !-------------------------- matriz A de U --------------------------------
         ! Inicializando a matriz A de U
         CALL self % A % init(self % Nx, self % Ny, &
                              self % hx, self % hy, self % ht, &
                              self % Re)

         ! Atribuindo um stencil a cada volume de A
         CALL self % A % atribui_stencils()

         ! Calculandos os coeficientes e posicoes dos stencils
         CALL self % A % stencils_u(1.0d0)
         !-------------------------- matriz A de U --------------------------------

         ! Inicializando o array de fontes de U
         DO st = 1, 9
            CALL self % FonteComplementosU(st) % init(st)
         END DO

         CALL calcula_exata(self)

         CALL Atualiza_Variaveis_MG_GS_U(self % Lx, self % Ly, &
                                         self % Nx, self % Ny, &
                                         self % Tolerancia, &
                                         3, 3, &
                                         50, &
                                         self % ht, &
                                         self % Re, self % Tn )

      END SUBROUTINE init

      SUBROUTINE aplica_condicao_inicial( self )
         USE FuncoesAlias

         CLASS (VelocidadeU), INTENT(INOUT) :: self

         INTEGER :: volume

         DO volume = 1, self % Nx * self % Ny

            self % u(volume, :) = u_inicial(0, volume)

         END DO

      END SUBROUTINE aplica_condicao_inicial

      SUBROUTINE calcula_exata( self )
         USE FuncoesAlias

         CLASS (VelocidadeU), INTENT(INOUT) :: self

         INTEGER :: volume, t

         DO t = 1, self % Tn

             DO volume = 1, self % Nx * self % Ny

                 self % u_ex(volume, t) = u_analitica(t, volume)

             END DO

         END DO

      END SUBROUTINE calcula_exata

      SUBROUTINE calcula_termo_fonte( self, t, t0, v, pressao, correcao)

         CLASS (VelocidadeU) :: self
         INTEGER :: t, t0
         DOUBLE PRECISION, DIMENSION(:, :), INTENT(IN) :: v, pressao, correcao

         INTEGER :: volume, pp, stencil
         DOUBLE PRECISION :: Du, Au, Au0, Complemento

         DO volume = 1, self % Nx * self % Ny

            ! Stencil do volume
            stencil = self % A % v(volume)
            !stencil = self % A % calcula_stencil(volume)

            ! Calculando a Adveccao e Difusao
            CALL self % FonteComplementosU(stencil) % CalculaComplementos(t, t0, &
                                                                          volume, &
                                                                          self % Nx, &
                                                                          self % hx, self % hy, self % ht, &
                                                                          self % Re, &
                                                                          self % u(:, t), self % u(:, t0), &
                                                                                v(:, t),        v(:, t0), &
                                                                          Du, Au, Au0, Complemento, pp )

            ! Aqui esta o calculo do termo fonte
            self % u_bp(volume, t) =  self % ht*( -1.5d0*Au + 0.5d0*Au0 - &
                                      ( pressao(pp+1, t) - pressao(pp, t) )/(self % hx) - &
                                      ( correcao(pp+1, t) - correcao(pp, t) )/(self % hx) ) &
                                      + 2.0d0 * Complemento !+ Sx(t, pu) )

         END DO

      END SUBROUTINE calcula_termo_fonte

      SUBROUTINE single_grid( self, t, rb )

         USE GS

         CLASS (VelocidadeU) :: self

         INTEGER, INTENT(IN) :: rb, t

         ! Resolvendo com Gauss Seidel
         CALL GaussSeidel_UV( self % A, self % u, self % u_bp, t, rb )

      END SUBROUTINE single_grid

      SUBROUTINE calcula_residuo( self, t )

         USE Residuo

         CLASS (VelocidadeU) :: self

         INTEGER, INTENT(IN) :: t

         ! Calcula residuo
         CALL calcula_residuo_UV( self % A, self % u, self % u_bp, self % residuo, t )

      END SUBROUTINE calcula_residuo

      SUBROUTINE calcula_norma_L2( self, t )

          USE Residuo

          CLASS (VelocidadeU) :: self

          INTEGER, INTENT(IN) :: t

          ! Calcula residuo
          self % normas_L2(t) = SUM(self % residuo(:, t) * self % residuo(:, t))

      END SUBROUTINE calcula_norma_L2

      SUBROUTINE escreve_matriz(self, nome, vetor)

         CLASS (VelocidadeU) :: self

         CHARACTER(len=*), INTENT(IN) :: nome
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: vetor

         INTEGER :: pu, i, j
         CHARACTER(len=(self % Nx*23)) :: linha
         CHARACTER(len=23) :: valor

         OPEN(UNIT=41, FILE=TRIM(ADJUSTL(nome)), STATUS='REPLACE', ACTION='WRITE')

         ! Para pontos internos
         DO j = 1, self % Ny
            DO i = 1, self % Nx

               pu = i + (j-1)* self % Nx

               WRITE(valor, "(1PE22.15)") vetor(pu)
               linha((i-1)*23+1:(i-1)*23+23) = valor

            END DO

            WRITE(41,1) linha

         END DO
         CLOSE(41)

         1 FORMAT( A )

      END SUBROUTINE escreve_matriz

      SUBROUTINE escreve_comparacao(self, tempo, nome, vetor)

         USE FuncoesAlias

         CLASS (VelocidadeU) :: self

         CHARACTER(len=*), INTENT(IN) :: nome
         INTEGER, INTENT(IN) :: tempo
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: vetor

         INTEGER :: pu, i, j, p_Linf
         DOUBLE PRECISION :: Linf

         1 FORMAT( 1PE22.15, 3X, 1PE22.15, 3X, 1PE22.15, 3X, I10, 3X, I10 )
         2 FORMAT( 1PE22.15, 1X, "= ht", /,  &
                   1PE22.15, 1X, "= Erro Maximo", /,  &
                   1PE22.15, 1X, "= Analitica (onde o erro aconteceu)", /, &
                   1PE22.15, 1X, "=  Numerica (onde o erro aconteceu)" )

         OPEN(UNIT=41, FILE=TRIM(ADJUSTL(nome)), STATUS='REPLACE', ACTION='WRITE')

         Linf   = 0.0d0
         p_Linf  = 0

         ! Para pontos internos
         DO j = 1, self % Ny
            DO i = 1, self % Nx

               pu = i + (j-1)* self % Nx

               !WRITE(41, 1) u_analitica(tempo, pu), vetor(pu), u_analitica(tempo, pu) - vetor(pu)

               IF ( ABS(u_analitica(tempo, pu) - vetor(pu)) > Linf ) THEN
                  Linf = ABS(u_analitica(tempo, pu) - vetor(pu))
                  p_Linf  = pu
               END IF

            END DO

         END DO

         WRITE(41, 2) self % ht, Linf, u_analitica(tempo, p_Linf), vetor(p_Linf)

         CLOSE(41)

      END SUBROUTINE escreve_comparacao

END MODULE ClassVelocidadeU


program produtorio
implicit none

integer :: c, cont

cont = 1
do c = 1,10
    cont = cont*c
end do

write(*,*) cont

end program produtorio


*> \brief \b DGET32
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DGET32( RMAX, LMAX, NINFO, KNT )
*
*       .. Scalar Arguments ..
*       INTEGER            KNT, LMAX, NINFO
*       DOUBLE PRECISION   RMAX
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DGET32 tests DLASY2, a routine for solving
*>
*>         op(TL)*X + ISGN*X*op(TR) = SCALE*B
*>
*> where TL is N1 by N1, TR is N2 by N2, and N1,N2 =1 or 2 only.
*> X and B are N1 by N2, op() is an optional transpose, an
*> ISGN = 1 or -1. SCALE is chosen less than or equal to 1 to
*> avoid overflow in X.
*>
*> The test condition is that the scaled residual
*>
*> norm( op(TL)*X + ISGN*X*op(TR) = SCALE*B )
*>      / ( max( ulp*norm(TL), ulp*norm(TR)) * norm(X), SMLNUM )
*>
*> should be on the order of 1. Here, ulp is the machine precision.
*> Also, it is verified that SCALE is less than or equal to 1, and
*> that XNORM = infinity-norm(X).
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[out] RMAX
*> \verbatim
*>          RMAX is DOUBLE PRECISION
*>          Value of the largest test ratio.
*> \endverbatim
*>
*> \param[out] LMAX
*> \verbatim
*>          LMAX is INTEGER
*>          Example number where largest test ratio achieved.
*> \endverbatim
*>
*> \param[out] NINFO
*> \verbatim
*>          NINFO is INTEGER
*>          Number of examples returned with INFO.NE.0.
*> \endverbatim
*>
*> \param[out] KNT
*> \verbatim
*>          KNT is INTEGER
*>          Total number of examples tested.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE DGET32( RMAX, LMAX, NINFO, KNT )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            KNT, LMAX, NINFO
      DOUBLE PRECISION   RMAX
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
      DOUBLE PRECISION   TWO, FOUR, EIGHT
      PARAMETER          ( TWO = 2.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LTRANL, LTRANR
      INTEGER            IB, IB1, IB2, IB3, INFO, ISGN, ITL, ITLSCL,
     $                   ITR, ITRANL, ITRANR, ITRSCL, N1, N2
      DOUBLE PRECISION   BIGNUM, DEN, EPS, RES, SCALE, SGN, SMLNUM, TMP,
     $                   TNRM, XNORM, XNRM
*     ..
*     .. Local Arrays ..
      INTEGER            ITVAL( 2, 2, 8 )
      DOUBLE PRECISION   B( 2, 2 ), TL( 2, 2 ), TR( 2, 2 ), VAL( 3 ),
     $                   X( 2, 2 )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLABAD, DLASY2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. Data statements ..
      DATA               ITVAL / 8, 4, 2, 1, 4, 8, 1, 2, 2, 1, 8, 4, 1,
     $                   2, 4, 8, 9, 4, 2, 1, 4, 9, 1, 2, 2, 1, 9, 4, 1,
     $                   2, 4, 9 /
*     ..
*     .. Executable Statements ..
*
*     Get machine parameters
*
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
*
*     Set up test case parameters
*
      VAL( 1 ) = SQRT( SMLNUM )
      VAL( 2 ) = ONE
      VAL( 3 ) = SQRT( BIGNUM )
*
      KNT = 0
      NINFO = 0
      LMAX = 0
      RMAX = ZERO
*
*     Begin test loop
*
      DO 230 ITRANL = 0, 1
         DO 220 ITRANR = 0, 1
            DO 210 ISGN = -1, 1, 2
               SGN = ISGN
               LTRANL = ITRANL.EQ.1
               LTRANR = ITRANR.EQ.1
*
               N1 = 1
               N2 = 1
               DO 30 ITL = 1, 3
                  DO 20 ITR = 1, 3
                     DO 10 IB = 1, 3
                        TL( 1, 1 ) = VAL( ITL )
                        TR( 1, 1 ) = VAL( ITR )
                        B( 1, 1 ) = VAL( IB )
                        KNT = KNT + 1
                        CALL DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL,
     $                               2, TR, 2, B, 2, SCALE, X, 2, XNORM,
     $                               INFO )
                        IF( INFO.NE.0 )
     $                     NINFO = NINFO + 1
                        RES = ABS( ( TL( 1, 1 )+SGN*TR( 1, 1 ) )*
     $                        X( 1, 1 )-SCALE*B( 1, 1 ) )
                        IF( INFO.EQ.0 ) THEN
                           DEN = MAX( EPS*( ( ABS( TR( 1,
     $                           1 ) )+ABS( TL( 1, 1 ) ) )*ABS( X( 1,
     $                           1 ) ) ), SMLNUM )
                        ELSE
                           DEN = SMLNUM*MAX( ABS( X( 1, 1 ) ), ONE )
                        END IF
                        RES = RES / DEN
                        IF( SCALE.GT.ONE )
     $                     RES = RES + ONE / EPS
                        RES = RES + ABS( XNORM-ABS( X( 1, 1 ) ) ) /
     $                        MAX( SMLNUM, XNORM ) / EPS
                        IF( INFO.NE.0 .AND. INFO.NE.1 )
     $                     RES = RES + ONE / EPS
                        IF( RES.GT.RMAX ) THEN
                           LMAX = KNT
                           RMAX = RES
                        END IF
   10                CONTINUE
   20             CONTINUE
   30          CONTINUE
*
               N1 = 2
               N2 = 1
               DO 80 ITL = 1, 8
                  DO 70 ITLSCL = 1, 3
                     DO 60 ITR = 1, 3
                        DO 50 IB1 = 1, 3
                           DO 40 IB2 = 1, 3
                              B( 1, 1 ) = VAL( IB1 )
                              B( 2, 1 ) = -FOUR*VAL( IB2 )
                              TL( 1, 1 ) = ITVAL( 1, 1, ITL )*
     $                                     VAL( ITLSCL )
                              TL( 2, 1 ) = ITVAL( 2, 1, ITL )*
     $                                     VAL( ITLSCL )
                              TL( 1, 2 ) = ITVAL( 1, 2, ITL )*
     $                                     VAL( ITLSCL )
                              TL( 2, 2 ) = ITVAL( 2, 2, ITL )*
     $                                     VAL( ITLSCL )
                              TR( 1, 1 ) = VAL( ITR )
                              KNT = KNT + 1
                              CALL DLASY2( LTRANL, LTRANR, ISGN, N1, N2,
     $                                     TL, 2, TR, 2, B, 2, SCALE, X,
     $                                     2, XNORM, INFO )
                              IF( INFO.NE.0 )
     $                           NINFO = NINFO + 1
                              IF( LTRANL ) THEN
                                 TMP = TL( 1, 2 )
                                 TL( 1, 2 ) = TL( 2, 1 )
                                 TL( 2, 1 ) = TMP
                              END IF
                              RES = ABS( ( TL( 1, 1 )+SGN*TR( 1, 1 ) )*
     $                              X( 1, 1 )+TL( 1, 2 )*X( 2, 1 )-
     $                              SCALE*B( 1, 1 ) )
                              RES = RES + ABS( ( TL( 2, 2 )+SGN*TR( 1,
     $                              1 ) )*X( 2, 1 )+TL( 2, 1 )*
     $                              X( 1, 1 )-SCALE*B( 2, 1 ) )
                              TNRM = ABS( TR( 1, 1 ) ) +
     $                               ABS( TL( 1, 1 ) ) +
     $                               ABS( TL( 1, 2 ) ) +
     $                               ABS( TL( 2, 1 ) ) +
     $                               ABS( TL( 2, 2 ) )
                              XNRM = MAX( ABS( X( 1, 1 ) ),
     $                               ABS( X( 2, 1 ) ) )
                              DEN = MAX( SMLNUM, SMLNUM*XNRM,
     $                              ( TNRM*EPS )*XNRM )
                              RES = RES / DEN
                              IF( SCALE.GT.ONE )
     $                           RES = RES + ONE / EPS
                              RES = RES + ABS( XNORM-XNRM ) /
     $                              MAX( SMLNUM, XNORM ) / EPS
                              IF( RES.GT.RMAX ) THEN
                                 LMAX = KNT
                                 RMAX = RES
                              END IF
   40                      CONTINUE
   50                   CONTINUE
   60                CONTINUE
   70             CONTINUE
   80          CONTINUE
*
               N1 = 1
               N2 = 2
               DO 130 ITR = 1, 8
                  DO 120 ITRSCL = 1, 3
                     DO 110 ITL = 1, 3
                        DO 100 IB1 = 1, 3
                           DO 90 IB2 = 1, 3
                              B( 1, 1 ) = VAL( IB1 )
                              B( 1, 2 ) = -TWO*VAL( IB2 )
                              TR( 1, 1 ) = ITVAL( 1, 1, ITR )*
     $                                     VAL( ITRSCL )
                              TR( 2, 1 ) = ITVAL( 2, 1, ITR )*
     $                                     VAL( ITRSCL )
                              TR( 1, 2 ) = ITVAL( 1, 2, ITR )*
     $                                     VAL( ITRSCL )
                              TR( 2, 2 ) = ITVAL( 2, 2, ITR )*
     $                                     VAL( ITRSCL )
                              TL( 1, 1 ) = VAL( ITL )
                              KNT = KNT + 1
                              CALL DLASY2( LTRANL, LTRANR, ISGN, N1, N2,
     $                                     TL, 2, TR, 2, B, 2, SCALE, X,
     $                                     2, XNORM, INFO )
                              IF( INFO.NE.0 )
     $                           NINFO = NINFO + 1
                              IF( LTRANR ) THEN
                                 TMP = TR( 1, 2 )
                                 TR( 1, 2 ) = TR( 2, 1 )
                                 TR( 2, 1 ) = TMP
                              END IF
                              TNRM = ABS( TL( 1, 1 ) ) +
     $                               ABS( TR( 1, 1 ) ) +
     $                               ABS( TR( 1, 2 ) ) +
     $                               ABS( TR( 2, 2 ) ) +
     $                               ABS( TR( 2, 1 ) )
                              XNRM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
                              RES = ABS( ( ( TL( 1, 1 )+SGN*TR( 1,
     $                              1 ) ) )*( X( 1, 1 ) )+
     $                              ( SGN*TR( 2, 1 ) )*( X( 1, 2 ) )-
     $                              ( SCALE*B( 1, 1 ) ) )
                              RES = RES + ABS( ( ( TL( 1, 1 )+SGN*TR( 2,
     $                              2 ) ) )*( X( 1, 2 ) )+
     $                              ( SGN*TR( 1, 2 ) )*( X( 1, 1 ) )-
     $                              ( SCALE*B( 1, 2 ) ) )
                              DEN = MAX( SMLNUM, SMLNUM*XNRM,
     $                              ( TNRM*EPS )*XNRM )
                              RES = RES / DEN
                              IF( SCALE.GT.ONE )
     $                           RES = RES + ONE / EPS
                              RES = RES + ABS( XNORM-XNRM ) /
     $                              MAX( SMLNUM, XNORM ) / EPS
                              IF( RES.GT.RMAX ) THEN
                                 LMAX = KNT
                                 RMAX = RES
                              END IF
   90                      CONTINUE
  100                   CONTINUE
  110                CONTINUE
  120             CONTINUE
  130          CONTINUE
*
               N1 = 2
               N2 = 2
               DO 200 ITR = 1, 8
                  DO 190 ITRSCL = 1, 3
                     DO 180 ITL = 1, 8
                        DO 170 ITLSCL = 1, 3
                           DO 160 IB1 = 1, 3
                              DO 150 IB2 = 1, 3
                                 DO 140 IB3 = 1, 3
                                    B( 1, 1 ) = VAL( IB1 )
                                    B( 2, 1 ) = -FOUR*VAL( IB2 )
                                    B( 1, 2 ) = -TWO*VAL( IB3 )
                                    B( 2, 2 ) = EIGHT*
     $                                          MIN( VAL( IB1 ), VAL
     $                                          ( IB2 ), VAL( IB3 ) )
                                    TR( 1, 1 ) = ITVAL( 1, 1, ITR )*
     $                                           VAL( ITRSCL )
                                    TR( 2, 1 ) = ITVAL( 2, 1, ITR )*
     $                                           VAL( ITRSCL )
                                    TR( 1, 2 ) = ITVAL( 1, 2, ITR )*
     $                                           VAL( ITRSCL )
                                    TR( 2, 2 ) = ITVAL( 2, 2, ITR )*
     $                                           VAL( ITRSCL )
                                    TL( 1, 1 ) = ITVAL( 1, 1, ITL )*
     $                                           VAL( ITLSCL )
                                    TL( 2, 1 ) = ITVAL( 2, 1, ITL )*
     $                                           VAL( ITLSCL )
                                    TL( 1, 2 ) = ITVAL( 1, 2, ITL )*
     $                                           VAL( ITLSCL )
                                    TL( 2, 2 ) = ITVAL( 2, 2, ITL )*
     $                                           VAL( ITLSCL )
                                    KNT = KNT + 1
                                    CALL DLASY2( LTRANL, LTRANR, ISGN,
     $                                           N1, N2, TL, 2, TR, 2,
     $                                           B, 2, SCALE, X, 2,
     $                                           XNORM, INFO )
                                    IF( INFO.NE.0 )
     $                                 NINFO = NINFO + 1
                                    IF( LTRANR ) THEN
                                       TMP = TR( 1, 2 )
                                       TR( 1, 2 ) = TR( 2, 1 )
                                       TR( 2, 1 ) = TMP
                                    END IF
                                    IF( LTRANL ) THEN
                                       TMP = TL( 1, 2 )
                                       TL( 1, 2 ) = TL( 2, 1 )
                                       TL( 2, 1 ) = TMP
                                    END IF
                                    TNRM = ABS( TR( 1, 1 ) ) +
     $                                     ABS( TR( 2, 1 ) ) +
     $                                     ABS( TR( 1, 2 ) ) +
     $                                     ABS( TR( 2, 2 ) ) +
     $                                     ABS( TL( 1, 1 ) ) +
     $                                     ABS( TL( 2, 1 ) ) +
     $                                     ABS( TL( 1, 2 ) ) +
     $                                     ABS( TL( 2, 2 ) )
                                    XNRM = MAX( ABS( X( 1, 1 ) )+
     $                                     ABS( X( 1, 2 ) ),
     $                                     ABS( X( 2, 1 ) )+
     $                                     ABS( X( 2, 2 ) ) )
                                    RES = ABS( ( ( TL( 1, 1 )+SGN*TR( 1,
     $                                    1 ) ) )*( X( 1, 1 ) )+
     $                                    ( SGN*TR( 2, 1 ) )*
     $                                    ( X( 1, 2 ) )+( TL( 1, 2 ) )*
     $                                    ( X( 2, 1 ) )-
     $                                    ( SCALE*B( 1, 1 ) ) )
                                    RES = RES + ABS( ( TL( 1, 1 ) )*
     $                                    ( X( 1, 2 ) )+
     $                                    ( SGN*TR( 1, 2 ) )*
     $                                    ( X( 1, 1 ) )+
     $                                    ( SGN*TR( 2, 2 ) )*
     $                                    ( X( 1, 2 ) )+( TL( 1, 2 ) )*
     $                                    ( X( 2, 2 ) )-
     $                                    ( SCALE*B( 1, 2 ) ) )
                                    RES = RES + ABS( ( TL( 2, 1 ) )*
     $                                    ( X( 1, 1 ) )+
     $                                    ( SGN*TR( 1, 1 ) )*
     $                                    ( X( 2, 1 ) )+
     $                                    ( SGN*TR( 2, 1 ) )*
     $                                    ( X( 2, 2 ) )+( TL( 2, 2 ) )*
     $                                    ( X( 2, 1 ) )-
     $                                    ( SCALE*B( 2, 1 ) ) )
                                    RES = RES + ABS( ( ( TL( 2,
     $                                    2 )+SGN*TR( 2, 2 ) ) )*
     $                                    ( X( 2, 2 ) )+
     $                                    ( SGN*TR( 1, 2 ) )*
     $                                    ( X( 2, 1 ) )+( TL( 2, 1 ) )*
     $                                    ( X( 1, 2 ) )-
     $                                    ( SCALE*B( 2, 2 ) ) )
                                    DEN = MAX( SMLNUM, SMLNUM*XNRM,
     $                                    ( TNRM*EPS )*XNRM )
                                    RES = RES / DEN
                                    IF( SCALE.GT.ONE )
     $                                 RES = RES + ONE / EPS
                                    RES = RES + ABS( XNORM-XNRM ) /
     $                                    MAX( SMLNUM, XNORM ) / EPS
                                    IF( RES.GT.RMAX ) THEN
                                       LMAX = KNT
                                       RMAX = RES
                                    END IF
  140                            CONTINUE
  150                         CONTINUE
  160                      CONTINUE
  170                   CONTINUE
  180                CONTINUE
  190             CONTINUE
  200          CONTINUE
  210       CONTINUE
  220    CONTINUE
  230 CONTINUE
*
      RETURN
*
*     End of DGET32
*
      END


program ch0512
    ! Rounding Problem
    implicit none

    real :: x1 = 1.
    real :: x2 = 0.1
    integer :: i

    print *, ' x1 = ', x1
    print *, ' x2 = ', x2
    do i = 1, 990
        x1 = x1+x2
    end do
    print *, ' x1 = ', x1
end program


\ FizzBuzz example for sectorforth, a 512-byte, bootable x86 Forth.
\ Copyright (c) 2020 Cesar Blum
\ Distributed under the MIT license. See LICENSE for details.
\ Depends on definitions built up to the stack debugging example.

\ get do...loop index
: i ( -- index ) rp@ 4 + @ ;

\ make more numbers
: 3 1 2 + ;
: 5 2 3 + ;

\ newline
: cr lit [ 4 6 3 + + , ] lit [ 4 6 + , ] emit emit ;

: fizzbuzz ( x -- )
    cr 1 + 1 do
        i 3 mod 0= dup if ." Fizz" then
        i 5 mod 0= dup if ." Buzz" then
        or invert if i . then
        cr
    loop ;