#:include "common.fypp"
submodule(stdlib_lapack_base) stdlib_lapack_blas_like_mnorm
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
real(sp) module function stdlib${ii}$_slange( norm, m, n, a, lda, work )
!! SLANGE returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, m
temp = abs( a( i, j ) )
if( value<temp .or. stdlib${ii}$_sisnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, m
sum = sum + abs( a( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, m
temp = work( i )
if( value<temp .or. stdlib${ii}$_sisnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_slassq( m, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_slange = value
return
end function stdlib${ii}$_slange
real(dp) module function stdlib${ii}$_dlange( norm, m, n, a, lda, work )
!! DLANGE returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, m
temp = abs( a( i, j ) )
if( value<temp .or. stdlib${ii}$_disnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, m
sum = sum + abs( a( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, m
temp = work( i )
if( value<temp .or. stdlib${ii}$_disnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_dlassq( m, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_dlange = value
return
end function stdlib${ii}$_dlange
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$lange( norm, m, n, a, lda, work )
!! DLANGE: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${rk}$) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, m
temp = abs( a( i, j ) )
if( value<temp .or. stdlib${ii}$_${ri}$isnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, m
sum = sum + abs( a( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, m
temp = work( i )
if( value<temp .or. stdlib${ii}$_${ri}$isnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$lange = value
return
end function stdlib${ii}$_${ri}$lange
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clange( norm, m, n, a, lda, work )
!! CLANGE returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, m
temp = abs( a( i, j ) )
if( value<temp .or. stdlib${ii}$_sisnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, m
sum = sum + abs( a( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, m
temp = work( i )
if( value<temp .or. stdlib${ii}$_sisnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_classq( m, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_clange = value
return
end function stdlib${ii}$_clange
real(dp) module function stdlib${ii}$_zlange( norm, m, n, a, lda, work )
!! ZLANGE returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, m
temp = abs( a( i, j ) )
if( value<temp .or. stdlib${ii}$_disnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, m
sum = sum + abs( a( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, m
temp = work( i )
if( value<temp .or. stdlib${ii}$_disnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_zlassq( m, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlange = value
return
end function stdlib${ii}$_zlange
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lange( norm, m, n, a, lda, work )
!! ZLANGE: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, m
temp = abs( a( i, j ) )
if( value<temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, m
sum = sum + abs( a( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, m
temp = work( i )
if( value<temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lange = value
return
end function stdlib${ii}$_${ci}$lange
#:endif
#:endfor
real(sp) module function stdlib${ii}$_slangb( norm, n, kl, ku, ab, ldab,work )
!! SLANGB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: kl, ku, ldab, n
! Array Arguments
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k, l
real(sp) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
temp = abs( ab( i, j ) )
if( value<temp .or. stdlib${ii}$_sisnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
sum = sum + abs( ab( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
k = ku + 1_${ik}$ - j
do i = max( 1, j-ku ), min( n, j+kl )
work( i ) = work( i ) + abs( ab( k+i, j ) )
end do
end do
value = zero
do i = 1, n
temp = work( i )
if( value<temp .or. stdlib${ii}$_sisnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
l = max( 1_${ik}$, j-ku )
k = ku + 1_${ik}$ - j + l
call stdlib${ii}$_slassq( min( n, j+kl )-l+1, ab( k, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_slangb = value
return
end function stdlib${ii}$_slangb
real(dp) module function stdlib${ii}$_dlangb( norm, n, kl, ku, ab, ldab,work )
!! DLANGB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: kl, ku, ldab, n
! Array Arguments
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k, l
real(dp) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
temp = abs( ab( i, j ) )
if( value<temp .or. stdlib${ii}$_disnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
sum = sum + abs( ab( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
k = ku + 1_${ik}$ - j
do i = max( 1, j-ku ), min( n, j+kl )
work( i ) = work( i ) + abs( ab( k+i, j ) )
end do
end do
value = zero
do i = 1, n
temp = work( i )
if( value<temp .or. stdlib${ii}$_disnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
l = max( 1_${ik}$, j-ku )
k = ku + 1_${ik}$ - j + l
call stdlib${ii}$_dlassq( min( n, j+kl )-l+1, ab( k, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_dlangb = value
return
end function stdlib${ii}$_dlangb
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$langb( norm, n, kl, ku, ab, ldab,work )
!! DLANGB: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: kl, ku, ldab, n
! Array Arguments
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k, l
real(${rk}$) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
temp = abs( ab( i, j ) )
if( value<temp .or. stdlib${ii}$_${ri}$isnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
sum = sum + abs( ab( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
k = ku + 1_${ik}$ - j
do i = max( 1, j-ku ), min( n, j+kl )
work( i ) = work( i ) + abs( ab( k+i, j ) )
end do
end do
value = zero
do i = 1, n
temp = work( i )
if( value<temp .or. stdlib${ii}$_${ri}$isnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
l = max( 1_${ik}$, j-ku )
k = ku + 1_${ik}$ - j + l
call stdlib${ii}$_${ri}$lassq( min( n, j+kl )-l+1, ab( k, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$langb = value
return
end function stdlib${ii}$_${ri}$langb
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clangb( norm, n, kl, ku, ab, ldab,work )
!! CLANGB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: kl, ku, ldab, n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k, l
real(sp) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
temp = abs( ab( i, j ) )
if( value<temp .or. stdlib${ii}$_sisnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
sum = sum + abs( ab( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
k = ku + 1_${ik}$ - j
do i = max( 1, j-ku ), min( n, j+kl )
work( i ) = work( i ) + abs( ab( k+i, j ) )
end do
end do
value = zero
do i = 1, n
temp = work( i )
if( value<temp .or. stdlib${ii}$_sisnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
l = max( 1_${ik}$, j-ku )
k = ku + 1_${ik}$ - j + l
call stdlib${ii}$_classq( min( n, j+kl )-l+1, ab( k, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_clangb = value
return
end function stdlib${ii}$_clangb
real(dp) module function stdlib${ii}$_zlangb( norm, n, kl, ku, ab, ldab,work )
!! ZLANGB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: kl, ku, ldab, n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k, l
real(dp) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
temp = abs( ab( i, j ) )
if( value<temp .or. stdlib${ii}$_disnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
sum = sum + abs( ab( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
k = ku + 1_${ik}$ - j
do i = max( 1, j-ku ), min( n, j+kl )
work( i ) = work( i ) + abs( ab( k+i, j ) )
end do
end do
value = zero
do i = 1, n
temp = work( i )
if( value<temp .or. stdlib${ii}$_disnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
l = max( 1_${ik}$, j-ku )
k = ku + 1_${ik}$ - j + l
call stdlib${ii}$_zlassq( min( n, j+kl )-l+1, ab( k, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlangb = value
return
end function stdlib${ii}$_zlangb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$langb( norm, n, kl, ku, ab, ldab,work )
!! ZLANGB: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: kl, ku, ldab, n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k, l
real(${ck}$) :: scale, sum, value, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
temp = abs( ab( i, j ) )
if( value<temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) ) value = temp
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
sum = sum + abs( ab( i, j ) )
end do
if( value<sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
k = ku + 1_${ik}$ - j
do i = max( 1, j-ku ), min( n, j+kl )
work( i ) = work( i ) + abs( ab( k+i, j ) )
end do
end do
value = zero
do i = 1, n
temp = work( i )
if( value<temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) ) value = temp
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
l = max( 1_${ik}$, j-ku )
k = ku + 1_${ik}$ - j + l
call stdlib${ii}$_${ci}$lassq( min( n, j+kl )-l+1, ab( k, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$langb = value
return
end function stdlib${ii}$_${ci}$langb
#:endif
#:endfor
pure real(sp) module function stdlib${ii}$_slangt( norm, n, dl, d, du )
!! SLANGT returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(in) :: d(*), dl(*), du(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: anorm, scale, sum, temp
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
if( anorm<abs( dl( i ) ) .or. stdlib${ii}$_sisnan( abs( dl( i ) ) ) )anorm = abs(dl(i))
if( anorm<abs( d( i ) ) .or. stdlib${ii}$_sisnan( abs( d( i ) ) ) )anorm = abs(d(i))
if( anorm<abs( du( i ) ) .or. stdlib${ii}$_sisnan (abs( du( i ) ) ) )anorm = abs(du(i))
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' ) then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( dl( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( du( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_sisnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( dl( i ) )+abs( du( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_sisnan( temp ) ) anorm = temp
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( du( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( dl( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_sisnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( du( i ) )+abs( dl( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_sisnan( temp ) ) anorm = temp
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
call stdlib${ii}$_slassq( n, d, 1_${ik}$, scale, sum )
if( n>1_${ik}$ ) then
call stdlib${ii}$_slassq( n-1, dl, 1_${ik}$, scale, sum )
call stdlib${ii}$_slassq( n-1, du, 1_${ik}$, scale, sum )
end if
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_slangt = anorm
return
end function stdlib${ii}$_slangt
pure real(dp) module function stdlib${ii}$_dlangt( norm, n, dl, d, du )
!! DLANGT returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(in) :: d(*), dl(*), du(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: anorm, scale, sum, temp
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
if( anorm<abs( dl( i ) ) .or. stdlib${ii}$_disnan( abs( dl( i ) ) ) )anorm = abs(dl(i))
if( anorm<abs( d( i ) ) .or. stdlib${ii}$_disnan( abs( d( i ) ) ) )anorm = abs(d(i))
if( anorm<abs( du( i ) ) .or. stdlib${ii}$_disnan (abs( du( i ) ) ) )anorm = abs(du(i))
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' ) then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( dl( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( du( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_disnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( dl( i ) )+abs( du( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_disnan( temp ) ) anorm = temp
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( du( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( dl( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_disnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( du( i ) )+abs( dl( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_disnan( temp ) ) anorm = temp
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
call stdlib${ii}$_dlassq( n, d, 1_${ik}$, scale, sum )
if( n>1_${ik}$ ) then
call stdlib${ii}$_dlassq( n-1, dl, 1_${ik}$, scale, sum )
call stdlib${ii}$_dlassq( n-1, du, 1_${ik}$, scale, sum )
end if
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_dlangt = anorm
return
end function stdlib${ii}$_dlangt
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure real(${rk}$) module function stdlib${ii}$_${ri}$langt( norm, n, dl, d, du )
!! DLANGT: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(in) :: d(*), dl(*), du(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${rk}$) :: anorm, scale, sum, temp
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
if( anorm<abs( dl( i ) ) .or. stdlib${ii}$_${ri}$isnan( abs( dl( i ) ) ) )anorm = abs(dl(i))
if( anorm<abs( d( i ) ) .or. stdlib${ii}$_${ri}$isnan( abs( d( i ) ) ) )anorm = abs(d(i))
if( anorm<abs( du( i ) ) .or. stdlib${ii}$_${ri}$isnan (abs( du( i ) ) ) )anorm = abs(du(i))
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' ) then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( dl( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( du( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_${ri}$isnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( dl( i ) )+abs( du( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_${ri}$isnan( temp ) ) anorm = temp
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( du( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( dl( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_${ri}$isnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( du( i ) )+abs( dl( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_${ri}$isnan( temp ) ) anorm = temp
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
call stdlib${ii}$_${ri}$lassq( n, d, 1_${ik}$, scale, sum )
if( n>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lassq( n-1, dl, 1_${ik}$, scale, sum )
call stdlib${ii}$_${ri}$lassq( n-1, du, 1_${ik}$, scale, sum )
end if
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$langt = anorm
return
end function stdlib${ii}$_${ri}$langt
#:endif
#:endfor
pure real(sp) module function stdlib${ii}$_clangt( norm, n, dl, d, du )
!! CLANGT returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(sp), intent(in) :: d(*), dl(*), du(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: anorm, scale, sum, temp
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
if( anorm<abs( dl( i ) ) .or. stdlib${ii}$_sisnan( abs( dl( i ) ) ) )anorm = abs(dl(i))
if( anorm<abs( d( i ) ) .or. stdlib${ii}$_sisnan( abs( d( i ) ) ) )anorm = abs(d(i))
if( anorm<abs( du( i ) ) .or. stdlib${ii}$_sisnan (abs( du( i ) ) ) )anorm = abs(du(i))
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' ) then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( dl( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( du( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_sisnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( dl( i ) )+abs( du( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_sisnan( temp ) ) anorm = temp
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( du( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( dl( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_sisnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( du( i ) )+abs( dl( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_sisnan( temp ) ) anorm = temp
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
call stdlib${ii}$_classq( n, d, 1_${ik}$, scale, sum )
if( n>1_${ik}$ ) then
call stdlib${ii}$_classq( n-1, dl, 1_${ik}$, scale, sum )
call stdlib${ii}$_classq( n-1, du, 1_${ik}$, scale, sum )
end if
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_clangt = anorm
return
end function stdlib${ii}$_clangt
pure real(dp) module function stdlib${ii}$_zlangt( norm, n, dl, d, du )
!! ZLANGT returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(dp), intent(in) :: d(*), dl(*), du(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: anorm, scale, sum, temp
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
if( anorm<abs( dl( i ) ) .or. stdlib${ii}$_disnan( abs( dl( i ) ) ) )anorm = abs(dl(i))
if( anorm<abs( d( i ) ) .or. stdlib${ii}$_disnan( abs( d( i ) ) ) )anorm = abs(d(i))
if( anorm<abs( du( i ) ) .or. stdlib${ii}$_disnan (abs( du( i ) ) ) )anorm = abs(du(i))
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' ) then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( dl( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( du( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_disnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( dl( i ) )+abs( du( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_disnan( temp ) ) anorm = temp
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( du( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( dl( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_disnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( du( i ) )+abs( dl( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_disnan( temp ) ) anorm = temp
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
call stdlib${ii}$_zlassq( n, d, 1_${ik}$, scale, sum )
if( n>1_${ik}$ ) then
call stdlib${ii}$_zlassq( n-1, dl, 1_${ik}$, scale, sum )
call stdlib${ii}$_zlassq( n-1, du, 1_${ik}$, scale, sum )
end if
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_zlangt = anorm
return
end function stdlib${ii}$_zlangt
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure real(${ck}$) module function stdlib${ii}$_${ci}$langt( norm, n, dl, d, du )
!! ZLANGT: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(${ck}$), intent(in) :: d(*), dl(*), du(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${ck}$) :: anorm, scale, sum, temp
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
if( anorm<abs( dl( i ) ) .or. stdlib${ii}$_${c2ri(ci)}$isnan( abs( dl( i ) ) ) )anorm = abs(dl(i))
if( anorm<abs( d( i ) ) .or. stdlib${ii}$_${c2ri(ci)}$isnan( abs( d( i ) ) ) )anorm = abs(d(i))
if( anorm<abs( du( i ) ) .or. stdlib${ii}$_${c2ri(ci)}$isnan (abs( du( i ) ) ) )anorm = abs(du(i))
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' ) then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( dl( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( du( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( dl( i ) )+abs( du( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) ) anorm = temp
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( du( 1_${ik}$ ) )
temp = abs( d( n ) )+abs( dl( n-1 ) )
if( anorm < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) ) anorm = temp
do i = 2, n - 1
temp = abs( d( i ) )+abs( du( i ) )+abs( dl( i-1 ) )
if( anorm < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) ) anorm = temp
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
call stdlib${ii}$_${ci}$lassq( n, d, 1_${ik}$, scale, sum )
if( n>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lassq( n-1, dl, 1_${ik}$, scale, sum )
call stdlib${ii}$_${ci}$lassq( n-1, du, 1_${ik}$, scale, sum )
end if
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$langt = anorm
return
end function stdlib${ii}$_${ci}$langt
#:endif
#:endfor
real(sp) module function stdlib${ii}$_slanhs( norm, n, a, lda, work )
!! SLANHS returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! Hessenberg matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, min( n, j+1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, min( n, j+1 )
sum = sum + abs( a( i, j ) )
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, min( n, j+1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_slassq( min( n, j+1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_slanhs = value
return
end function stdlib${ii}$_slanhs
real(dp) module function stdlib${ii}$_dlanhs( norm, n, a, lda, work )
!! DLANHS returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! Hessenberg matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, min( n, j+1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, min( n, j+1 )
sum = sum + abs( a( i, j ) )
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, min( n, j+1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_dlassq( min( n, j+1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_dlanhs = value
return
end function stdlib${ii}$_dlanhs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$lanhs( norm, n, a, lda, work )
!! DLANHS: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! Hessenberg matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${rk}$) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, min( n, j+1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, min( n, j+1 )
sum = sum + abs( a( i, j ) )
end do
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, min( n, j+1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ri}$lassq( min( n, j+1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$lanhs = value
return
end function stdlib${ii}$_${ri}$lanhs
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clanhs( norm, n, a, lda, work )
!! CLANHS returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! Hessenberg matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, min( n, j+1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, min( n, j+1 )
sum = sum + abs( a( i, j ) )
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, min( n, j+1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_classq( min( n, j+1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_clanhs = value
return
end function stdlib${ii}$_clanhs
real(dp) module function stdlib${ii}$_zlanhs( norm, n, a, lda, work )
!! ZLANHS returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! Hessenberg matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, min( n, j+1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, min( n, j+1 )
sum = sum + abs( a( i, j ) )
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, min( n, j+1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_zlassq( min( n, j+1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlanhs = value
return
end function stdlib${ii}$_zlanhs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lanhs( norm, n, a, lda, work )
!! ZLANHS: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! Hessenberg matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
do j = 1, n
do i = 1, min( n, j+1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
do j = 1, n
sum = zero
do i = 1, min( n, j+1 )
sum = sum + abs( a( i, j ) )
end do
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, min( n, j+1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ci}$lassq( min( n, j+1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lanhs = value
return
end function stdlib${ii}$_${ci}$lanhs
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clanhf( norm, transr, uplo, n, a, work )
!! CLANHF returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex Hermitian matrix A in RFP format.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, transr, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(out) :: work(0_${ik}$:*)
complex(sp), intent(in) :: a(0_${ik}$:*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, ifm, ilu, noe, n1, k, l, lda
real(sp) :: scale, s, value, aa, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
stdlib${ii}$_clanhf = zero
return
else if( n==1_${ik}$ ) then
stdlib${ii}$_clanhf = abs(real(a(0_${ik}$),KIND=sp))
return
end if
! set noe = 1 if n is odd. if n is even set noe=0
noe = 1_${ik}$
if( mod( n, 2_${ik}$ )==0_${ik}$ )noe = 0_${ik}$
! set ifm = 0 when form='c' or 'c' and 1 otherwise
ifm = 1_${ik}$
if( stdlib_lsame( transr, 'C' ) )ifm = 0_${ik}$
! set ilu = 0 when uplo='u or 'u' and 1 otherwise
ilu = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) )ilu = 0_${ik}$
! set lda = (n+1)/2 when ifm = 0
! set lda = n when ifm = 1 and noe = 1
! set lda = n+1 when ifm = 1 and noe = 0
if( ifm==1_${ik}$ ) then
if( noe==1_${ik}$ ) then
lda = n
else
! noe=0
lda = n + 1_${ik}$
end if
else
! ifm=0
lda = ( n+1 ) / 2_${ik}$
end if
if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = ( n+1 ) / 2_${ik}$
value = zero
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is n by k
if( ilu==1_${ik}$ ) then
! uplo ='l'
j = 0_${ik}$
! -> l(0,0)
temp = abs( real( a( j+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = 1, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
do j = 1, k - 1
do i = 0, j - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = j - 1_${ik}$
! l(k+j,k+j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
i = j
! -> l(j,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = j + 1, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 2
do i = 0, k + j - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = k + j - 1_${ik}$
! -> u(i,i)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
i = i + 1_${ik}$
! =k+j; i -> u(j,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = k + j + 1, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
do i = 0, n - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
! j=k-1
end do
! i=n-1 -> u(n-1,n-1)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end if
else
! xpose case; a is k by n
if( ilu==1_${ik}$ ) then
! uplo ='l'
do j = 0, k - 2
do i = 0, j - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = j
! l(i,i)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
i = j + 1_${ik}$
! l(j+k,j+k)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = j + 2, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
j = k - 1_${ik}$
do i = 0, k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = k - 1_${ik}$
! -> l(i,i) is at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do j = k, n - 1
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 2
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
j = k - 1_${ik}$
! -> u(j,j) is at a(0,j)
temp = abs( real( a( 0_${ik}$+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
do j = k, n - 1
do i = 0, j - k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = j - k
! -> u(i,i) at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
i = j - k + 1_${ik}$
! u(j,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = j - k + 2, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
end if
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is n+1 by k
if( ilu==1_${ik}$ ) then
! uplo ='l'
j = 0_${ik}$
! -> l(k,k)
temp = abs( real( a( j+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
temp = abs( real( a( j+1+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = 2, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
do j = 1, k - 1
do i = 0, j - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = j
! l(k+j,k+j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
i = j + 1_${ik}$
! -> l(j,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = j + 2, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 2
do i = 0, k + j - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = k + j
! -> u(i,i)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
i = i + 1_${ik}$
! =k+j+1; i -> u(j,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = k + j + 2, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
do i = 0, n - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
! j=k-1
end do
! i=n-1 -> u(n-1,n-1)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
i = n
! -> u(k-1,k-1)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end if
else
! xpose case; a is k by n+1
if( ilu==1_${ik}$ ) then
! uplo ='l'
j = 0_${ik}$
! -> l(k,k) at a(0,0)
temp = abs( real( a( j+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
do j = 1, k - 1
do i = 0, j - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = j - 1_${ik}$
! l(i,i)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
i = j
! l(j+k,j+k)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = j + 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
j = k
do i = 0, k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = k - 1_${ik}$
! -> l(i,i) is at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do j = k + 1, n
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 1
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
j = k
! -> u(j,j) is at a(0,j)
temp = abs( real( a( 0_${ik}$+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
do j = k + 1, n - 1
do i = 0, j - k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = j - k - 1_${ik}$
! -> u(i,i) at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
i = j - k
! u(j,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
do i = j - k + 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
j = n
do i = 0, k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
i = k - 1_${ik}$
! u(k,k) at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=sp) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end if
end if
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
if( ifm==1_${ik}$ ) then
! a is 'n'
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
! uplo = 'u'
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( real( a( i+j*lda ),KIND=sp) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
if( i==k+k )go to 10
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=sp) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
10 continue
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
else
! ilu = 1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
if( j>0_${ik}$ ) then
aa = abs( real( a( i+j*lda ),KIND=sp) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
end if
aa = abs( real( a( i+j*lda ),KIND=sp) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
! uplo = 'u'
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( real( a( i+j*lda ),KIND=sp) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=sp) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
else
! ilu = 1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
aa = abs( real( a( i+j*lda ),KIND=sp) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=sp) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end if
end if
else
! ifm=0
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
! uplo = 'u'
n1 = k
! n/2
k = k + 1_${ik}$
! k is the row size and lda
do i = n1, n - 1
work( i ) = zero
end do
do j = 0, n1 - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,n1+i)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=n1=k-1 is special
s = abs( real( a( 0_${ik}$+j*lda ),KIND=sp) )
! a(k-1,k-1)
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k-1,i+n1)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k, n - 1
s = zero
do i = 0, j - k - 1
aa = abs( a( i+j*lda ) )
! a(i,j-k)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-k
aa = abs( real( a( i+j*lda ),KIND=sp) )
! a(j-k,j-k)
s = s + aa
work( j-k ) = work( j-k ) + s
i = i + 1_${ik}$
s = abs( real( a( i+j*lda ),KIND=sp) )
! a(j,j)
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
else
! ilu=1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 2
! process
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( real( a( i+j*lda ),KIND=sp) )
! i=j so process of a(j,j)
s = s + aa
work( j ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( real( a( i+j*lda ),KIND=sp) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k-1 is special :process col a(k-1,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( real( a( i+j*lda ),KIND=sp) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k, n - 1
! process col j of a = a(j,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
! uplo = 'u'
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i+k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=k
aa = abs( real( a( 0_${ik}$+j*lda ),KIND=sp) )
! a(k,k)
s = aa
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k,k+i)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k + 1, n - 1
s = zero
do i = 0, j - 2 - k
aa = abs( a( i+j*lda ) )
! a(i,j-k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-1-k
aa = abs( real( a( i+j*lda ),KIND=sp) )
! a(j-k-1,j-k-1)
s = s + aa
work( j-k-1 ) = work( j-k-1 ) + s
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=sp) )
! a(j,j)
s = aa
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
! j=n
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(i,k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( real( a( i+j*lda ),KIND=sp) )
! a(k-1,k-1)
s = s + aa
work( i ) = work( i ) + s
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
else
! ilu=1
do i = k, n - 1
work( i ) = zero
end do
! j=0 is special :process col a(k:n-1,k)
s = abs( real( a( 0_${ik}$ ),KIND=sp) )
! a(k,k)
do i = 1, k - 1
aa = abs( a( i ) )
! a(k+i,k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( k ) = work( k ) + s
do j = 1, k - 1
! process
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( real( a( i+j*lda ),KIND=sp) )
! i=j-1 so process of a(j-1,j-1)
s = s + aa
work( j-1 ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( real( a( i+j*lda ),KIND=sp) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k is special :process col a(k,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( real( a( i+j*lda ),KIND=sp) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k + 1, n
! process col j-1 of a = a(j-1,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j-1 ) = work( j-1 ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end if
end if
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
k = ( n+1 ) / 2_${ik}$
scale = zero
s = one
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 3
call stdlib${ii}$_classq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(k,0)
end do
do j = 0, k - 1
call stdlib${ii}$_classq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = k - 1_${ik}$
! -> u(k,k) at a(k-1,0)
do i = 0, k - 2
aa = real( a( l ),KIND=sp)
! u(k+i,k+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=sp)
! u(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
aa = real( a( l ),KIND=sp)
! u(n-1,n-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_classq( n-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! trap l at a(0,0)
end do
do j = 1, k - 2
call stdlib${ii}$_classq( j, a( 0_${ik}$+( 1_${ik}$+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
s = s + s
! double s for the off diagonal elements
aa = real( a( 0_${ik}$ ),KIND=sp)
! l(0,0) at a(0,0)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = lda
! -> l(k,k) at a(0,1)
do i = 1, k - 1
aa = real( a( l ),KIND=sp)
! l(k-1+i,k-1+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=sp)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**h is upper
do j = 1, k - 2
call stdlib${ii}$_classq( j, a( 0_${ik}$+( k+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k)
end do
do j = 0, k - 2
call stdlib${ii}$_classq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_classq( k-j-1, a( j+1+( j+k-1 )*lda ), 1_${ik}$,scale, s )
! l at a(0,k-1)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$ + k*lda - lda
! -> u(k-1,k-1) at a(0,k-1)
aa = real( a( l ),KIND=sp)
! u(k-1,k-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda
! -> u(0,0) at a(0,k)
do j = k, n - 1
aa = real( a( l ),KIND=sp)
! -> u(j-k,j-k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=sp)
! -> u(j,j)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
else
! a**h is lower
do j = 1, k - 1
call stdlib${ii}$_classq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
do j = k, n - 1
call stdlib${ii}$_classq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,k)
end do
do j = 0, k - 3
call stdlib${ii}$_classq( k-j-2, a( j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(1,0)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$
! -> l(0,0) at a(0,0)
do i = 0, k - 2
aa = real( a( l ),KIND=sp)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=sp)
! l(k+i,k+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
! l-> k-1 + (k-1)*lda or l(k-1,k-1) at a(k-1,k-1)
aa = real( a( l ),KIND=sp)
! l(k-1,k-1) at a(k-1,k-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
end if
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 2
call stdlib${ii}$_classq( k-j-1, a( k+j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(k+1,0)
end do
do j = 0, k - 1
call stdlib${ii}$_classq( k+j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = k
! -> u(k,k) at a(k,0)
do i = 0, k - 1
aa = real( a( l ),KIND=sp)
! u(k+i,k+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=sp)
! u(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_classq( n-j-1, a( j+2+j*lda ), 1_${ik}$, scale, s )
! trap l at a(1,0)
end do
do j = 1, k - 1
call stdlib${ii}$_classq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$
! -> l(k,k) at a(0,0)
do i = 0, k - 1
aa = real( a( l ),KIND=sp)
! l(k-1+i,k-1+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=sp)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**h is upper
do j = 1, k - 1
call stdlib${ii}$_classq( j, a( 0_${ik}$+( k+1+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k+1)
end do
do j = 0, k - 1
call stdlib${ii}$_classq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_classq( k-j-1, a( j+1+( j+k )*lda ), 1_${ik}$, scale,s )
! l at a(0,k)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$ + k*lda
! -> u(k,k) at a(0,k)
aa = real( a( l ),KIND=sp)
! u(k,k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda
! -> u(0,0) at a(0,k+1)
do j = k + 1, n - 1
aa = real( a( l ),KIND=sp)
! -> u(j-k-1,j-k-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=sp)
! -> u(j,j)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
! l=k-1+n*lda
! -> u(k-1,k-1) at a(k-1,n)
aa = real( a( l ),KIND=sp)
! u(k,k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
else
! a**h is lower
do j = 1, k - 1
call stdlib${ii}$_classq( j, a( 0_${ik}$+( j+1 )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
do j = k + 1, n
call stdlib${ii}$_classq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,k+1)
end do
do j = 0, k - 2
call stdlib${ii}$_classq( k-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$
! -> l(k,k) at a(0,0)
aa = real( a( l ),KIND=sp)
! l(k,k) at a(0,0)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = lda
! -> l(0,0) at a(0,1)
do i = 0, k - 2
aa = real( a( l ),KIND=sp)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=sp)
! l(k+i+1,k+i+1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
! l-> k - 1 + k*lda or l(k-1,k-1) at a(k-1,k)
aa = real( a( l ),KIND=sp)
! l(k-1,k-1) at a(k-1,k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
end if
end if
end if
value = scale*sqrt( s )
end if
stdlib${ii}$_clanhf = value
return
end function stdlib${ii}$_clanhf
real(dp) module function stdlib${ii}$_zlanhf( norm, transr, uplo, n, a, work )
!! ZLANHF returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex Hermitian matrix A in RFP format.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, transr, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(out) :: work(0_${ik}$:*)
complex(dp), intent(in) :: a(0_${ik}$:*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, ifm, ilu, noe, n1, k, l, lda
real(dp) :: scale, s, value, aa, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
stdlib${ii}$_zlanhf = zero
return
else if( n==1_${ik}$ ) then
stdlib${ii}$_zlanhf = abs(real(a(0_${ik}$),KIND=dp))
return
end if
! set noe = 1 if n is odd. if n is even set noe=0
noe = 1_${ik}$
if( mod( n, 2_${ik}$ )==0_${ik}$ )noe = 0_${ik}$
! set ifm = 0 when form='c' or 'c' and 1 otherwise
ifm = 1_${ik}$
if( stdlib_lsame( transr, 'C' ) )ifm = 0_${ik}$
! set ilu = 0 when uplo='u or 'u' and 1 otherwise
ilu = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) )ilu = 0_${ik}$
! set lda = (n+1)/2 when ifm = 0
! set lda = n when ifm = 1 and noe = 1
! set lda = n+1 when ifm = 1 and noe = 0
if( ifm==1_${ik}$ ) then
if( noe==1_${ik}$ ) then
lda = n
else
! noe=0
lda = n + 1_${ik}$
end if
else
! ifm=0
lda = ( n+1 ) / 2_${ik}$
end if
if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = ( n+1 ) / 2_${ik}$
value = zero
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is n by k
if( ilu==1_${ik}$ ) then
! uplo ='l'
j = 0_${ik}$
! -> l(0,0)
temp = abs( real( a( j+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = 1, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
do j = 1, k - 1
do i = 0, j - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = j - 1_${ik}$
! l(k+j,k+j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
i = j
! -> l(j,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = j + 1, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 2
do i = 0, k + j - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = k + j - 1_${ik}$
! -> u(i,i)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
i = i + 1_${ik}$
! =k+j; i -> u(j,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = k + j + 1, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
do i = 0, n - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
! j=k-1
end do
! i=n-1 -> u(n-1,n-1)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end if
else
! xpose case; a is k by n
if( ilu==1_${ik}$ ) then
! uplo ='l'
do j = 0, k - 2
do i = 0, j - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = j
! l(i,i)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
i = j + 1_${ik}$
! l(j+k,j+k)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = j + 2, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
j = k - 1_${ik}$
do i = 0, k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = k - 1_${ik}$
! -> l(i,i) is at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do j = k, n - 1
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 2
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
j = k - 1_${ik}$
! -> u(j,j) is at a(0,j)
temp = abs( real( a( 0_${ik}$+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
do j = k, n - 1
do i = 0, j - k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = j - k
! -> u(i,i) at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
i = j - k + 1_${ik}$
! u(j,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = j - k + 2, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
end if
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is n+1 by k
if( ilu==1_${ik}$ ) then
! uplo ='l'
j = 0_${ik}$
! -> l(k,k)
temp = abs( real( a( j+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
temp = abs( real( a( j+1+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = 2, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
do j = 1, k - 1
do i = 0, j - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = j
! l(k+j,k+j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
i = j + 1_${ik}$
! -> l(j,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = j + 2, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 2
do i = 0, k + j - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = k + j
! -> u(i,i)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
i = i + 1_${ik}$
! =k+j+1; i -> u(j,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = k + j + 2, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
do i = 0, n - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
! j=k-1
end do
! i=n-1 -> u(n-1,n-1)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
i = n
! -> u(k-1,k-1)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end if
else
! xpose case; a is k by n+1
if( ilu==1_${ik}$ ) then
! uplo ='l'
j = 0_${ik}$
! -> l(k,k) at a(0,0)
temp = abs( real( a( j+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
do j = 1, k - 1
do i = 0, j - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = j - 1_${ik}$
! l(i,i)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
i = j
! l(j+k,j+k)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = j + 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
j = k
do i = 0, k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = k - 1_${ik}$
! -> l(i,i) is at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do j = k + 1, n
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 1
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
j = k
! -> u(j,j) is at a(0,j)
temp = abs( real( a( 0_${ik}$+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
do j = k + 1, n - 1
do i = 0, j - k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = j - k - 1_${ik}$
! -> u(i,i) at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
i = j - k
! u(j,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
do i = j - k + 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
j = n
do i = 0, k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
i = k - 1_${ik}$
! u(k,k) at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=dp) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end if
end if
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
if( ifm==1_${ik}$ ) then
! a is 'n'
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
! uplo = 'u'
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( real( a( i+j*lda ),KIND=dp) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
if( i==k+k )go to 10
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=dp) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
10 continue
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
else
! ilu = 1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
if( j>0_${ik}$ ) then
aa = abs( real( a( i+j*lda ),KIND=dp) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
end if
aa = abs( real( a( i+j*lda ),KIND=dp) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
! uplo = 'u'
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( real( a( i+j*lda ),KIND=dp) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=dp) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
else
! ilu = 1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
aa = abs( real( a( i+j*lda ),KIND=dp) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=dp) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end if
end if
else
! ifm=0
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
! uplo = 'u'
n1 = k
! n/2
k = k + 1_${ik}$
! k is the row size and lda
do i = n1, n - 1
work( i ) = zero
end do
do j = 0, n1 - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,n1+i)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=n1=k-1 is special
s = abs( real( a( 0_${ik}$+j*lda ),KIND=dp) )
! a(k-1,k-1)
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k-1,i+n1)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k, n - 1
s = zero
do i = 0, j - k - 1
aa = abs( a( i+j*lda ) )
! a(i,j-k)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-k
aa = abs( real( a( i+j*lda ),KIND=dp) )
! a(j-k,j-k)
s = s + aa
work( j-k ) = work( j-k ) + s
i = i + 1_${ik}$
s = abs( real( a( i+j*lda ),KIND=dp) )
! a(j,j)
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
else
! ilu=1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 2
! process
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( real( a( i+j*lda ),KIND=dp) )
! i=j so process of a(j,j)
s = s + aa
work( j ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( real( a( i+j*lda ),KIND=dp) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k-1 is special :process col a(k-1,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( real( a( i+j*lda ),KIND=dp) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k, n - 1
! process col j of a = a(j,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
! uplo = 'u'
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i+k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=k
aa = abs( real( a( 0_${ik}$+j*lda ),KIND=dp) )
! a(k,k)
s = aa
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k,k+i)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k + 1, n - 1
s = zero
do i = 0, j - 2 - k
aa = abs( a( i+j*lda ) )
! a(i,j-k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-1-k
aa = abs( real( a( i+j*lda ),KIND=dp) )
! a(j-k-1,j-k-1)
s = s + aa
work( j-k-1 ) = work( j-k-1 ) + s
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=dp) )
! a(j,j)
s = aa
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
! j=n
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(i,k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( real( a( i+j*lda ),KIND=dp) )
! a(k-1,k-1)
s = s + aa
work( i ) = work( i ) + s
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
else
! ilu=1
do i = k, n - 1
work( i ) = zero
end do
! j=0 is special :process col a(k:n-1,k)
s = abs( real( a( 0_${ik}$ ),KIND=dp) )
! a(k,k)
do i = 1, k - 1
aa = abs( a( i ) )
! a(k+i,k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( k ) = work( k ) + s
do j = 1, k - 1
! process
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( real( a( i+j*lda ),KIND=dp) )
! i=j-1 so process of a(j-1,j-1)
s = s + aa
work( j-1 ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( real( a( i+j*lda ),KIND=dp) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k is special :process col a(k,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( real( a( i+j*lda ),KIND=dp) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k + 1, n
! process col j-1 of a = a(j-1,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j-1 ) = work( j-1 ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end if
end if
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
k = ( n+1 ) / 2_${ik}$
scale = zero
s = one
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 3
call stdlib${ii}$_zlassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(k,0)
end do
do j = 0, k - 1
call stdlib${ii}$_zlassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = k - 1_${ik}$
! -> u(k,k) at a(k-1,0)
do i = 0, k - 2
aa = real( a( l ),KIND=dp)
! u(k+i,k+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=dp)
! u(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
aa = real( a( l ),KIND=dp)
! u(n-1,n-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_zlassq( n-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! trap l at a(0,0)
end do
do j = 1, k - 2
call stdlib${ii}$_zlassq( j, a( 0_${ik}$+( 1_${ik}$+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
s = s + s
! double s for the off diagonal elements
aa = real( a( 0_${ik}$ ),KIND=dp)
! l(0,0) at a(0,0)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = lda
! -> l(k,k) at a(0,1)
do i = 1, k - 1
aa = real( a( l ),KIND=dp)
! l(k-1+i,k-1+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=dp)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**h is upper
do j = 1, k - 2
call stdlib${ii}$_zlassq( j, a( 0_${ik}$+( k+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k)
end do
do j = 0, k - 2
call stdlib${ii}$_zlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_zlassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1_${ik}$,scale, s )
! l at a(0,k-1)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$ + k*lda - lda
! -> u(k-1,k-1) at a(0,k-1)
aa = real( a( l ),KIND=dp)
! u(k-1,k-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda
! -> u(0,0) at a(0,k)
do j = k, n - 1
aa = real( a( l ),KIND=dp)
! -> u(j-k,j-k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=dp)
! -> u(j,j)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
else
! a**h is lower
do j = 1, k - 1
call stdlib${ii}$_zlassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
do j = k, n - 1
call stdlib${ii}$_zlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,k)
end do
do j = 0, k - 3
call stdlib${ii}$_zlassq( k-j-2, a( j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(1,0)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$
! -> l(0,0) at a(0,0)
do i = 0, k - 2
aa = real( a( l ),KIND=dp)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=dp)
! l(k+i,k+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
! l-> k-1 + (k-1)*lda or l(k-1,k-1) at a(k-1,k-1)
aa = real( a( l ),KIND=dp)
! l(k-1,k-1) at a(k-1,k-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
end if
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 2
call stdlib${ii}$_zlassq( k-j-1, a( k+j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(k+1,0)
end do
do j = 0, k - 1
call stdlib${ii}$_zlassq( k+j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = k
! -> u(k,k) at a(k,0)
do i = 0, k - 1
aa = real( a( l ),KIND=dp)
! u(k+i,k+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=dp)
! u(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_zlassq( n-j-1, a( j+2+j*lda ), 1_${ik}$, scale, s )
! trap l at a(1,0)
end do
do j = 1, k - 1
call stdlib${ii}$_zlassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$
! -> l(k,k) at a(0,0)
do i = 0, k - 1
aa = real( a( l ),KIND=dp)
! l(k-1+i,k-1+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=dp)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**h is upper
do j = 1, k - 1
call stdlib${ii}$_zlassq( j, a( 0_${ik}$+( k+1+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k+1)
end do
do j = 0, k - 1
call stdlib${ii}$_zlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_zlassq( k-j-1, a( j+1+( j+k )*lda ), 1_${ik}$, scale,s )
! l at a(0,k)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$ + k*lda
! -> u(k,k) at a(0,k)
aa = real( a( l ),KIND=dp)
! u(k,k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda
! -> u(0,0) at a(0,k+1)
do j = k + 1, n - 1
aa = real( a( l ),KIND=dp)
! -> u(j-k-1,j-k-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=dp)
! -> u(j,j)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
! l=k-1+n*lda
! -> u(k-1,k-1) at a(k-1,n)
aa = real( a( l ),KIND=dp)
! u(k,k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
else
! a**h is lower
do j = 1, k - 1
call stdlib${ii}$_zlassq( j, a( 0_${ik}$+( j+1 )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
do j = k + 1, n
call stdlib${ii}$_zlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,k+1)
end do
do j = 0, k - 2
call stdlib${ii}$_zlassq( k-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$
! -> l(k,k) at a(0,0)
aa = real( a( l ),KIND=dp)
! l(k,k) at a(0,0)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = lda
! -> l(0,0) at a(0,1)
do i = 0, k - 2
aa = real( a( l ),KIND=dp)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=dp)
! l(k+i+1,k+i+1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
! l-> k - 1 + k*lda or l(k-1,k-1) at a(k-1,k)
aa = real( a( l ),KIND=dp)
! l(k-1,k-1) at a(k-1,k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
end if
end if
end if
value = scale*sqrt( s )
end if
stdlib${ii}$_zlanhf = value
return
end function stdlib${ii}$_zlanhf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lanhf( norm, transr, uplo, n, a, work )
!! ZLANHF: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex Hermitian matrix A in RFP format.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, transr, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${ck}$), intent(out) :: work(0_${ik}$:*)
complex(${ck}$), intent(in) :: a(0_${ik}$:*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, ifm, ilu, noe, n1, k, l, lda
real(${ck}$) :: scale, s, value, aa, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
stdlib${ii}$_${ci}$lanhf = zero
return
else if( n==1_${ik}$ ) then
stdlib${ii}$_${ci}$lanhf = abs(real(a(0_${ik}$),KIND=${ck}$))
return
end if
! set noe = 1 if n is odd. if n is even set noe=0
noe = 1_${ik}$
if( mod( n, 2_${ik}$ )==0_${ik}$ )noe = 0_${ik}$
! set ifm = 0 when form='c' or 'c' and 1 otherwise
ifm = 1_${ik}$
if( stdlib_lsame( transr, 'C' ) )ifm = 0_${ik}$
! set ilu = 0 when uplo='u or 'u' and 1 otherwise
ilu = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) )ilu = 0_${ik}$
! set lda = (n+1)/2 when ifm = 0
! set lda = n when ifm = 1 and noe = 1
! set lda = n+1 when ifm = 1 and noe = 0
if( ifm==1_${ik}$ ) then
if( noe==1_${ik}$ ) then
lda = n
else
! noe=0
lda = n + 1_${ik}$
end if
else
! ifm=0
lda = ( n+1 ) / 2_${ik}$
end if
if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = ( n+1 ) / 2_${ik}$
value = zero
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is n by k
if( ilu==1_${ik}$ ) then
! uplo ='l'
j = 0_${ik}$
! -> l(0,0)
temp = abs( real( a( j+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = 1, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
do j = 1, k - 1
do i = 0, j - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = j - 1_${ik}$
! l(k+j,k+j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
i = j
! -> l(j,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = j + 1, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 2
do i = 0, k + j - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = k + j - 1_${ik}$
! -> u(i,i)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
i = i + 1_${ik}$
! =k+j; i -> u(j,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = k + j + 1, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
do i = 0, n - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
! j=k-1
end do
! i=n-1 -> u(n-1,n-1)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end if
else
! xpose case; a is k by n
if( ilu==1_${ik}$ ) then
! uplo ='l'
do j = 0, k - 2
do i = 0, j - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = j
! l(i,i)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
i = j + 1_${ik}$
! l(j+k,j+k)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = j + 2, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
j = k - 1_${ik}$
do i = 0, k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = k - 1_${ik}$
! -> l(i,i) is at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do j = k, n - 1
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 2
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
j = k - 1_${ik}$
! -> u(j,j) is at a(0,j)
temp = abs( real( a( 0_${ik}$+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
do j = k, n - 1
do i = 0, j - k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = j - k
! -> u(i,i) at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
i = j - k + 1_${ik}$
! u(j,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = j - k + 2, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
end if
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is n+1 by k
if( ilu==1_${ik}$ ) then
! uplo ='l'
j = 0_${ik}$
! -> l(k,k)
temp = abs( real( a( j+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
temp = abs( real( a( j+1+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = 2, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
do j = 1, k - 1
do i = 0, j - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = j
! l(k+j,k+j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
i = j + 1_${ik}$
! -> l(j,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = j + 2, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 2
do i = 0, k + j - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = k + j
! -> u(i,i)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
i = i + 1_${ik}$
! =k+j+1; i -> u(j,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = k + j + 2, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
do i = 0, n - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
! j=k-1
end do
! i=n-1 -> u(n-1,n-1)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
i = n
! -> u(k-1,k-1)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end if
else
! xpose case; a is k by n+1
if( ilu==1_${ik}$ ) then
! uplo ='l'
j = 0_${ik}$
! -> l(k,k) at a(0,0)
temp = abs( real( a( j+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
do j = 1, k - 1
do i = 0, j - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = j - 1_${ik}$
! l(i,i)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
i = j
! l(j+k,j+k)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = j + 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
j = k
do i = 0, k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = k - 1_${ik}$
! -> l(i,i) is at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do j = k + 1, n
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
else
! uplo = 'u'
do j = 0, k - 1
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
j = k
! -> u(j,j) is at a(0,j)
temp = abs( real( a( 0_${ik}$+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
do j = k + 1, n - 1
do i = 0, j - k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = j - k - 1_${ik}$
! -> u(i,i) at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
i = j - k
! u(j,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
do i = j - k + 1, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end do
j = n
do i = 0, k - 2
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
i = k - 1_${ik}$
! u(k,k) at a(i,j)
temp = abs( real( a( i+j*lda ),KIND=${ck}$) )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end if
end if
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
if( ifm==1_${ik}$ ) then
! a is 'n'
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
! uplo = 'u'
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
if( i==k+k )go to 10
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
10 continue
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
else
! ilu = 1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
if( j>0_${ik}$ ) then
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
end if
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
! uplo = 'u'
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
else
! ilu = 1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end if
end if
else
! ifm=0
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
! uplo = 'u'
n1 = k
! n/2
k = k + 1_${ik}$
! k is the row size and lda
do i = n1, n - 1
work( i ) = zero
end do
do j = 0, n1 - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,n1+i)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=n1=k-1 is special
s = abs( real( a( 0_${ik}$+j*lda ),KIND=${ck}$) )
! a(k-1,k-1)
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k-1,i+n1)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k, n - 1
s = zero
do i = 0, j - k - 1
aa = abs( a( i+j*lda ) )
! a(i,j-k)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-k
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! a(j-k,j-k)
s = s + aa
work( j-k ) = work( j-k ) + s
i = i + 1_${ik}$
s = abs( real( a( i+j*lda ),KIND=${ck}$) )
! a(j,j)
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
else
! ilu=1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 2
! process
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! i=j so process of a(j,j)
s = s + aa
work( j ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k-1 is special :process col a(k-1,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k, n - 1
! process col j of a = a(j,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
! uplo = 'u'
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i+k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=k
aa = abs( real( a( 0_${ik}$+j*lda ),KIND=${ck}$) )
! a(k,k)
s = aa
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k,k+i)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k + 1, n - 1
s = zero
do i = 0, j - 2 - k
aa = abs( a( i+j*lda ) )
! a(i,j-k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-1-k
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! a(j-k-1,j-k-1)
s = s + aa
work( j-k-1 ) = work( j-k-1 ) + s
i = i + 1_${ik}$
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! a(j,j)
s = aa
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
! j=n
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(i,k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! a(k-1,k-1)
s = s + aa
work( i ) = work( i ) + s
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
else
! ilu=1
do i = k, n - 1
work( i ) = zero
end do
! j=0 is special :process col a(k:n-1,k)
s = abs( real( a( 0_${ik}$ ),KIND=${ck}$) )
! a(k,k)
do i = 1, k - 1
aa = abs( a( i ) )
! a(k+i,k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( k ) = work( k ) + s
do j = 1, k - 1
! process
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! i=j-1 so process of a(j-1,j-1)
s = s + aa
work( j-1 ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k is special :process col a(k,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( real( a( i+j*lda ),KIND=${ck}$) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k + 1, n
! process col j-1 of a = a(j-1,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j-1 ) = work( j-1 ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp
end do
end if
end if
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
k = ( n+1 ) / 2_${ik}$
scale = zero
s = one
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 3
call stdlib${ii}$_${ci}$lassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(k,0)
end do
do j = 0, k - 1
call stdlib${ii}$_${ci}$lassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = k - 1_${ik}$
! -> u(k,k) at a(k-1,0)
do i = 0, k - 2
aa = real( a( l ),KIND=${ck}$)
! u(k+i,k+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=${ck}$)
! u(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
aa = real( a( l ),KIND=${ck}$)
! u(n-1,n-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_${ci}$lassq( n-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! trap l at a(0,0)
end do
do j = 1, k - 2
call stdlib${ii}$_${ci}$lassq( j, a( 0_${ik}$+( 1_${ik}$+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
s = s + s
! double s for the off diagonal elements
aa = real( a( 0_${ik}$ ),KIND=${ck}$)
! l(0,0) at a(0,0)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = lda
! -> l(k,k) at a(0,1)
do i = 1, k - 1
aa = real( a( l ),KIND=${ck}$)
! l(k-1+i,k-1+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=${ck}$)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**h is upper
do j = 1, k - 2
call stdlib${ii}$_${ci}$lassq( j, a( 0_${ik}$+( k+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k)
end do
do j = 0, k - 2
call stdlib${ii}$_${ci}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_${ci}$lassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1_${ik}$,scale, s )
! l at a(0,k-1)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$ + k*lda - lda
! -> u(k-1,k-1) at a(0,k-1)
aa = real( a( l ),KIND=${ck}$)
! u(k-1,k-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda
! -> u(0,0) at a(0,k)
do j = k, n - 1
aa = real( a( l ),KIND=${ck}$)
! -> u(j-k,j-k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=${ck}$)
! -> u(j,j)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
else
! a**h is lower
do j = 1, k - 1
call stdlib${ii}$_${ci}$lassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
do j = k, n - 1
call stdlib${ii}$_${ci}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,k)
end do
do j = 0, k - 3
call stdlib${ii}$_${ci}$lassq( k-j-2, a( j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(1,0)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$
! -> l(0,0) at a(0,0)
do i = 0, k - 2
aa = real( a( l ),KIND=${ck}$)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=${ck}$)
! l(k+i,k+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
! l-> k-1 + (k-1)*lda or l(k-1,k-1) at a(k-1,k-1)
aa = real( a( l ),KIND=${ck}$)
! l(k-1,k-1) at a(k-1,k-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
end if
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 2
call stdlib${ii}$_${ci}$lassq( k-j-1, a( k+j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(k+1,0)
end do
do j = 0, k - 1
call stdlib${ii}$_${ci}$lassq( k+j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = k
! -> u(k,k) at a(k,0)
do i = 0, k - 1
aa = real( a( l ),KIND=${ck}$)
! u(k+i,k+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=${ck}$)
! u(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_${ci}$lassq( n-j-1, a( j+2+j*lda ), 1_${ik}$, scale, s )
! trap l at a(1,0)
end do
do j = 1, k - 1
call stdlib${ii}$_${ci}$lassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$
! -> l(k,k) at a(0,0)
do i = 0, k - 1
aa = real( a( l ),KIND=${ck}$)
! l(k-1+i,k-1+i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=${ck}$)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**h is upper
do j = 1, k - 1
call stdlib${ii}$_${ci}$lassq( j, a( 0_${ik}$+( k+1+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k+1)
end do
do j = 0, k - 1
call stdlib${ii}$_${ci}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_${ci}$lassq( k-j-1, a( j+1+( j+k )*lda ), 1_${ik}$, scale,s )
! l at a(0,k)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$ + k*lda
! -> u(k,k) at a(0,k)
aa = real( a( l ),KIND=${ck}$)
! u(k,k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda
! -> u(0,0) at a(0,k+1)
do j = k + 1, n - 1
aa = real( a( l ),KIND=${ck}$)
! -> u(j-k-1,j-k-1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=${ck}$)
! -> u(j,j)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
! l=k-1+n*lda
! -> u(k-1,k-1) at a(k-1,n)
aa = real( a( l ),KIND=${ck}$)
! u(k,k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
else
! a**h is lower
do j = 1, k - 1
call stdlib${ii}$_${ci}$lassq( j, a( 0_${ik}$+( j+1 )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
do j = k + 1, n
call stdlib${ii}$_${ci}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,k+1)
end do
do j = 0, k - 2
call stdlib${ii}$_${ci}$lassq( k-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
l = 0_${ik}$
! -> l(k,k) at a(0,0)
aa = real( a( l ),KIND=${ck}$)
! l(k,k) at a(0,0)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = lda
! -> l(0,0) at a(0,1)
do i = 0, k - 2
aa = real( a( l ),KIND=${ck}$)
! l(i,i)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
aa = real( a( l+1 ),KIND=${ck}$)
! l(k+i+1,k+i+1)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
l = l + lda + 1_${ik}$
end do
! l-> k - 1 + k*lda or l(k-1,k-1) at a(k-1,k)
aa = real( a( l ),KIND=${ck}$)
! l(k-1,k-1) at a(k-1,k)
if( aa/=zero ) then
if( scale<aa ) then
s = one + s*( scale / aa )**2_${ik}$
scale = aa
else
s = s + ( aa / scale )**2_${ik}$
end if
end if
end if
end if
end if
value = scale*sqrt( s )
end if
stdlib${ii}$_${ci}$lanhf = value
return
end function stdlib${ii}$_${ci}$lanhf
#:endif
#:endfor
real(sp) module function stdlib${ii}$_slansf( norm, transr, uplo, n, a, work )
!! SLANSF returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric matrix A in RFP format.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, transr, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(in) :: a(0_${ik}$:*)
real(sp), intent(out) :: work(0_${ik}$:*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, ifm, ilu, noe, n1, k, l, lda
real(sp) :: scale, s, value, aa, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
stdlib${ii}$_slansf = zero
return
else if( n==1_${ik}$ ) then
stdlib${ii}$_slansf = abs( a(0_${ik}$) )
return
end if
! set noe = 1 if n is odd. if n is even set noe=0
noe = 1_${ik}$
if( mod( n, 2_${ik}$ )==0_${ik}$ )noe = 0_${ik}$
! set ifm = 0 when form='t or 't' and 1 otherwise
ifm = 1_${ik}$
if( stdlib_lsame( transr, 'T' ) )ifm = 0_${ik}$
! set ilu = 0 when uplo='u or 'u' and 1 otherwise
ilu = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) )ilu = 0_${ik}$
! set lda = (n+1)/2 when ifm = 0
! set lda = n when ifm = 1 and noe = 1
! set lda = n+1 when ifm = 1 and noe = 0
if( ifm==1_${ik}$ ) then
if( noe==1_${ik}$ ) then
lda = n
else
! noe=0
lda = n + 1_${ik}$
end if
else
! ifm=0
lda = ( n+1 ) / 2_${ik}$
end if
if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = ( n+1 ) / 2_${ik}$
value = zero
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is n by k
do j = 0, k - 1
do i = 0, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
else
! xpose case; a is k by n
do j = 0, n - 1
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is n+1 by k
do j = 0, k - 1
do i = 0, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
else
! xpose case; a is k by n+1
do j = 0, n
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
if( ifm==1_${ik}$ ) then
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
if( i==k+k )go to 10
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
10 continue
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
else
! ilu = 1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
if( j>0_${ik}$ ) then
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
end if
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
else
! ilu = 1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end if
end if
else
! ifm=0
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
n1 = k
! n/2
k = k + 1_${ik}$
! k is the row size and lda
do i = n1, n - 1
work( i ) = zero
end do
do j = 0, n1 - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,n1+i)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=n1=k-1 is special
s = abs( a( 0_${ik}$+j*lda ) )
! a(k-1,k-1)
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k-1,i+n1)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k, n - 1
s = zero
do i = 0, j - k - 1
aa = abs( a( i+j*lda ) )
! a(i,j-k)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-k
aa = abs( a( i+j*lda ) )
! a(j-k,j-k)
s = s + aa
work( j-k ) = work( j-k ) + s
i = i + 1_${ik}$
s = abs( a( i+j*lda ) )
! a(j,j)
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
else
! ilu=1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 2
! process
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( a( i+j*lda ) )
! i=j so process of a(j,j)
s = s + aa
work( j ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( a( i+j*lda ) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k-1 is special :process col a(k-1,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( a( i+j*lda ) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k, n - 1
! process col j of a = a(j,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i+k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=k
aa = abs( a( 0_${ik}$+j*lda ) )
! a(k,k)
s = aa
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k,k+i)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k + 1, n - 1
s = zero
do i = 0, j - 2 - k
aa = abs( a( i+j*lda ) )
! a(i,j-k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-1-k
aa = abs( a( i+j*lda ) )
! a(j-k-1,j-k-1)
s = s + aa
work( j-k-1 ) = work( j-k-1 ) + s
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,j)
s = aa
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
! j=n
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(i,k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( a( i+j*lda ) )
! a(k-1,k-1)
s = s + aa
work( i ) = work( i ) + s
value = work ( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
else
! ilu=1
do i = k, n - 1
work( i ) = zero
end do
! j=0 is special :process col a(k:n-1,k)
s = abs( a( 0_${ik}$ ) )
! a(k,k)
do i = 1, k - 1
aa = abs( a( i ) )
! a(k+i,k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( k ) = work( k ) + s
do j = 1, k - 1
! process
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( a( i+j*lda ) )
! i=j-1 so process of a(j-1,j-1)
s = s + aa
work( j-1 ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( a( i+j*lda ) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k is special :process col a(k,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( a( i+j*lda ) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k + 1, n
! process col j-1 of a = a(j-1,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j-1 ) = work( j-1 ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp
end do
end if
end if
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
k = ( n+1 ) / 2_${ik}$
scale = zero
s = one
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 3
call stdlib${ii}$_slassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(k,0)
end do
do j = 0, k - 1
call stdlib${ii}$_slassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_slassq( k-1, a( k ), lda+1, scale, s )
! tri l at a(k,0)
call stdlib${ii}$_slassq( k, a( k-1 ), lda+1, scale, s )
! tri u at a(k-1,0)
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_slassq( n-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! trap l at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_slassq( j, a( 0_${ik}$+( 1_${ik}$+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri l at a(0,0)
call stdlib${ii}$_slassq( k-1, a( 0_${ik}$+lda ), lda+1, scale, s )
! tri u at a(0,1)
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**t is upper
do j = 1, k - 2
call stdlib${ii}$_slassq( j, a( 0_${ik}$+( k+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k)
end do
do j = 0, k - 2
call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_slassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1_${ik}$,scale, s )
! l at a(0,k-1)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_slassq( k-1, a( 0_${ik}$+k*lda ), lda+1, scale, s )
! tri u at a(0,k)
call stdlib${ii}$_slassq( k, a( 0_${ik}$+( k-1 )*lda ), lda+1, scale, s )
! tri l at a(0,k-1)
else
! a**t is lower
do j = 1, k - 1
call stdlib${ii}$_slassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
do j = k, n - 1
call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,k)
end do
do j = 0, k - 3
call stdlib${ii}$_slassq( k-j-2, a( j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(1,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri u at a(0,0)
call stdlib${ii}$_slassq( k-1, a( 1_${ik}$ ), lda+1, scale, s )
! tri l at a(1,0)
end if
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 2
call stdlib${ii}$_slassq( k-j-1, a( k+j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(k+1,0)
end do
do j = 0, k - 1
call stdlib${ii}$_slassq( k+j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_slassq( k, a( k+1 ), lda+1, scale, s )
! tri l at a(k+1,0)
call stdlib${ii}$_slassq( k, a( k ), lda+1, scale, s )
! tri u at a(k,0)
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_slassq( n-j-1, a( j+2+j*lda ), 1_${ik}$, scale, s )
! trap l at a(1,0)
end do
do j = 1, k - 1
call stdlib${ii}$_slassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_slassq( k, a( 1_${ik}$ ), lda+1, scale, s )
! tri l at a(1,0)
call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri u at a(0,0)
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**t is upper
do j = 1, k - 1
call stdlib${ii}$_slassq( j, a( 0_${ik}$+( k+1+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k+1)
end do
do j = 0, k - 1
call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_slassq( k-j-1, a( j+1+( j+k )*lda ), 1_${ik}$, scale,s )
! l at a(0,k)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_slassq( k, a( 0_${ik}$+( k+1 )*lda ), lda+1, scale, s )
! tri u at a(0,k+1)
call stdlib${ii}$_slassq( k, a( 0_${ik}$+k*lda ), lda+1, scale, s )
! tri l at a(0,k)
else
! a**t is lower
do j = 1, k - 1
call stdlib${ii}$_slassq( j, a( 0_${ik}$+( j+1 )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
do j = k + 1, n
call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,k+1)
end do
do j = 0, k - 2
call stdlib${ii}$_slassq( k-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_slassq( k, a( lda ), lda+1, scale, s )
! tri l at a(0,1)
call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri u at a(0,0)
end if
end if
end if
value = scale*sqrt( s )
end if
stdlib${ii}$_slansf = value
return
end function stdlib${ii}$_slansf
real(dp) module function stdlib${ii}$_dlansf( norm, transr, uplo, n, a, work )
!! DLANSF returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric matrix A in RFP format.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, transr, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(in) :: a(0_${ik}$:*)
real(dp), intent(out) :: work(0_${ik}$:*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, ifm, ilu, noe, n1, k, l, lda
real(dp) :: scale, s, value, aa, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
stdlib${ii}$_dlansf = zero
return
else if( n==1_${ik}$ ) then
stdlib${ii}$_dlansf = abs( a(0_${ik}$) )
return
end if
! set noe = 1 if n is odd. if n is even set noe=0
noe = 1_${ik}$
if( mod( n, 2_${ik}$ )==0_${ik}$ )noe = 0_${ik}$
! set ifm = 0 when form='t or 't' and 1 otherwise
ifm = 1_${ik}$
if( stdlib_lsame( transr, 'T' ) )ifm = 0_${ik}$
! set ilu = 0 when uplo='u or 'u' and 1 otherwise
ilu = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) )ilu = 0_${ik}$
! set lda = (n+1)/2 when ifm = 0
! set lda = n when ifm = 1 and noe = 1
! set lda = n+1 when ifm = 1 and noe = 0
if( ifm==1_${ik}$ ) then
if( noe==1_${ik}$ ) then
lda = n
else
! noe=0
lda = n + 1_${ik}$
end if
else
! ifm=0
lda = ( n+1 ) / 2_${ik}$
end if
if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = ( n+1 ) / 2_${ik}$
value = zero
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is n by k
do j = 0, k - 1
do i = 0, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
else
! xpose case; a is k by n
do j = 0, n - 1
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is n+1 by k
do j = 0, k - 1
do i = 0, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
else
! xpose case; a is k by n+1
do j = 0, n
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
if( ifm==1_${ik}$ ) then
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
if( i==k+k )go to 10
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
10 continue
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
else
! ilu = 1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
if( j>0_${ik}$ ) then
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
end if
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
else
! ilu = 1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end if
end if
else
! ifm=0
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
n1 = k
! n/2
k = k + 1_${ik}$
! k is the row size and lda
do i = n1, n - 1
work( i ) = zero
end do
do j = 0, n1 - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,n1+i)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=n1=k-1 is special
s = abs( a( 0_${ik}$+j*lda ) )
! a(k-1,k-1)
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k-1,i+n1)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k, n - 1
s = zero
do i = 0, j - k - 1
aa = abs( a( i+j*lda ) )
! a(i,j-k)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-k
aa = abs( a( i+j*lda ) )
! a(j-k,j-k)
s = s + aa
work( j-k ) = work( j-k ) + s
i = i + 1_${ik}$
s = abs( a( i+j*lda ) )
! a(j,j)
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
else
! ilu=1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 2
! process
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( a( i+j*lda ) )
! i=j so process of a(j,j)
s = s + aa
work( j ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( a( i+j*lda ) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k-1 is special :process col a(k-1,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( a( i+j*lda ) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k, n - 1
! process col j of a = a(j,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i+k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=k
aa = abs( a( 0_${ik}$+j*lda ) )
! a(k,k)
s = aa
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k,k+i)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k + 1, n - 1
s = zero
do i = 0, j - 2 - k
aa = abs( a( i+j*lda ) )
! a(i,j-k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-1-k
aa = abs( a( i+j*lda ) )
! a(j-k-1,j-k-1)
s = s + aa
work( j-k-1 ) = work( j-k-1 ) + s
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,j)
s = aa
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
! j=n
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(i,k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( a( i+j*lda ) )
! a(k-1,k-1)
s = s + aa
work( i ) = work( i ) + s
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
else
! ilu=1
do i = k, n - 1
work( i ) = zero
end do
! j=0 is special :process col a(k:n-1,k)
s = abs( a( 0_${ik}$ ) )
! a(k,k)
do i = 1, k - 1
aa = abs( a( i ) )
! a(k+i,k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( k ) = work( k ) + s
do j = 1, k - 1
! process
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( a( i+j*lda ) )
! i=j-1 so process of a(j-1,j-1)
s = s + aa
work( j-1 ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( a( i+j*lda ) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k is special :process col a(k,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( a( i+j*lda ) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k + 1, n
! process col j-1 of a = a(j-1,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j-1 ) = work( j-1 ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp
end do
end if
end if
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
k = ( n+1 ) / 2_${ik}$
scale = zero
s = one
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 3
call stdlib${ii}$_dlassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(k,0)
end do
do j = 0, k - 1
call stdlib${ii}$_dlassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_dlassq( k-1, a( k ), lda+1, scale, s )
! tri l at a(k,0)
call stdlib${ii}$_dlassq( k, a( k-1 ), lda+1, scale, s )
! tri u at a(k-1,0)
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_dlassq( n-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! trap l at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_dlassq( j, a( 0_${ik}$+( 1_${ik}$+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_dlassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri l at a(0,0)
call stdlib${ii}$_dlassq( k-1, a( 0_${ik}$+lda ), lda+1, scale, s )
! tri u at a(0,1)
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**t is upper
do j = 1, k - 2
call stdlib${ii}$_dlassq( j, a( 0_${ik}$+( k+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k)
end do
do j = 0, k - 2
call stdlib${ii}$_dlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_dlassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1_${ik}$,scale, s )
! l at a(0,k-1)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_dlassq( k-1, a( 0_${ik}$+k*lda ), lda+1, scale, s )
! tri u at a(0,k)
call stdlib${ii}$_dlassq( k, a( 0_${ik}$+( k-1 )*lda ), lda+1, scale, s )
! tri l at a(0,k-1)
else
! a**t is lower
do j = 1, k - 1
call stdlib${ii}$_dlassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
do j = k, n - 1
call stdlib${ii}$_dlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,k)
end do
do j = 0, k - 3
call stdlib${ii}$_dlassq( k-j-2, a( j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(1,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_dlassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri u at a(0,0)
call stdlib${ii}$_dlassq( k-1, a( 1_${ik}$ ), lda+1, scale, s )
! tri l at a(1,0)
end if
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 2
call stdlib${ii}$_dlassq( k-j-1, a( k+j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(k+1,0)
end do
do j = 0, k - 1
call stdlib${ii}$_dlassq( k+j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_dlassq( k, a( k+1 ), lda+1, scale, s )
! tri l at a(k+1,0)
call stdlib${ii}$_dlassq( k, a( k ), lda+1, scale, s )
! tri u at a(k,0)
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_dlassq( n-j-1, a( j+2+j*lda ), 1_${ik}$, scale, s )
! trap l at a(1,0)
end do
do j = 1, k - 1
call stdlib${ii}$_dlassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_dlassq( k, a( 1_${ik}$ ), lda+1, scale, s )
! tri l at a(1,0)
call stdlib${ii}$_dlassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri u at a(0,0)
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**t is upper
do j = 1, k - 1
call stdlib${ii}$_dlassq( j, a( 0_${ik}$+( k+1+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k+1)
end do
do j = 0, k - 1
call stdlib${ii}$_dlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_dlassq( k-j-1, a( j+1+( j+k )*lda ), 1_${ik}$, scale,s )
! l at a(0,k)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_dlassq( k, a( 0_${ik}$+( k+1 )*lda ), lda+1, scale, s )
! tri u at a(0,k+1)
call stdlib${ii}$_dlassq( k, a( 0_${ik}$+k*lda ), lda+1, scale, s )
! tri l at a(0,k)
else
! a**t is lower
do j = 1, k - 1
call stdlib${ii}$_dlassq( j, a( 0_${ik}$+( j+1 )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
do j = k + 1, n
call stdlib${ii}$_dlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,k+1)
end do
do j = 0, k - 2
call stdlib${ii}$_dlassq( k-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_dlassq( k, a( lda ), lda+1, scale, s )
! tri l at a(0,1)
call stdlib${ii}$_dlassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri u at a(0,0)
end if
end if
end if
value = scale*sqrt( s )
end if
stdlib${ii}$_dlansf = value
return
end function stdlib${ii}$_dlansf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$lansf( norm, transr, uplo, n, a, work )
!! DLANSF: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric matrix A in RFP format.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, transr, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(in) :: a(0_${ik}$:*)
real(${rk}$), intent(out) :: work(0_${ik}$:*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, ifm, ilu, noe, n1, k, l, lda
real(${rk}$) :: scale, s, value, aa, temp
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
stdlib${ii}$_${ri}$lansf = zero
return
else if( n==1_${ik}$ ) then
stdlib${ii}$_${ri}$lansf = abs( a(0_${ik}$) )
return
end if
! set noe = 1 if n is odd. if n is even set noe=0
noe = 1_${ik}$
if( mod( n, 2_${ik}$ )==0_${ik}$ )noe = 0_${ik}$
! set ifm = 0 when form='t or 't' and 1 otherwise
ifm = 1_${ik}$
if( stdlib_lsame( transr, 'T' ) )ifm = 0_${ik}$
! set ilu = 0 when uplo='u or 'u' and 1 otherwise
ilu = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) )ilu = 0_${ik}$
! set lda = (n+1)/2 when ifm = 0
! set lda = n when ifm = 1 and noe = 1
! set lda = n+1 when ifm = 1 and noe = 0
if( ifm==1_${ik}$ ) then
if( noe==1_${ik}$ ) then
lda = n
else
! noe=0
lda = n + 1_${ik}$
end if
else
! ifm=0
lda = ( n+1 ) / 2_${ik}$
end if
if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = ( n+1 ) / 2_${ik}$
value = zero
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is n by k
do j = 0, k - 1
do i = 0, n - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
end do
else
! xpose case; a is k by n
do j = 0, n - 1
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
end do
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is n+1 by k
do j = 0, k - 1
do i = 0, n
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
end do
else
! xpose case; a is k by n+1
do j = 0, n
do i = 0, k - 1
temp = abs( a( i+j*lda ) )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
if( ifm==1_${ik}$ ) then
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
if( i==k+k )go to 10
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
10 continue
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
else
! ilu = 1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
if( j>0_${ik}$ ) then
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
end if
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
do i = 0, k - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k + j - 1
aa = abs( a( i+j*lda ) )
! -> a(i,j+k)
s = s + aa
work( i ) = work( i ) + aa
end do
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
work( j+k ) = s + aa
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = work( j ) + aa
s = zero
do l = j + 1, k - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
else
! ilu = 1
do i = k, n - 1
work( i ) = zero
end do
do j = k - 1, 0, -1
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! -> a(j+k,i+k)
s = s + aa
work( i+k ) = work( i+k ) + aa
end do
aa = abs( a( i+j*lda ) )
! -> a(j+k,j+k)
s = s + aa
work( i+k ) = work( i+k ) + s
! i=j
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(j,j)
work( j ) = aa
s = zero
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! -> a(l,j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
end if
end if
else
! ifm=0
k = n / 2_${ik}$
if( noe==1_${ik}$ ) then
! n is odd
if( ilu==0_${ik}$ ) then
n1 = k
! n/2
k = k + 1_${ik}$
! k is the row size and lda
do i = n1, n - 1
work( i ) = zero
end do
do j = 0, n1 - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,n1+i)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=n1=k-1 is special
s = abs( a( 0_${ik}$+j*lda ) )
! a(k-1,k-1)
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k-1,i+n1)
work( i+n1 ) = work( i+n1 ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k, n - 1
s = zero
do i = 0, j - k - 1
aa = abs( a( i+j*lda ) )
! a(i,j-k)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-k
aa = abs( a( i+j*lda ) )
! a(j-k,j-k)
s = s + aa
work( j-k ) = work( j-k ) + s
i = i + 1_${ik}$
s = abs( a( i+j*lda ) )
! a(j,j)
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
else
! ilu=1
k = k + 1_${ik}$
! k=(n+1)/2 for n odd and ilu=1
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 2
! process
s = zero
do i = 0, j - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( a( i+j*lda ) )
! i=j so process of a(j,j)
s = s + aa
work( j ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( a( i+j*lda ) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k-1 is special :process col a(k-1,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( a( i+j*lda ) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k, n - 1
! process col j of a = a(j,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
end if
else
! n is even
if( ilu==0_${ik}$ ) then
do i = k, n - 1
work( i ) = zero
end do
do j = 0, k - 1
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j,i+k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = s
end do
! j=k
aa = abs( a( 0_${ik}$+j*lda ) )
! a(k,k)
s = aa
do i = 1, k - 1
aa = abs( a( i+j*lda ) )
! a(k,k+i)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
do j = k + 1, n - 1
s = zero
do i = 0, j - 2 - k
aa = abs( a( i+j*lda ) )
! a(i,j-k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=j-1-k
aa = abs( a( i+j*lda ) )
! a(j-k-1,j-k-1)
s = s + aa
work( j-k-1 ) = work( j-k-1 ) + s
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,j)
s = aa
do l = j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(j,l)
work( l ) = work( l ) + aa
s = s + aa
end do
work( j ) = work( j ) + s
end do
! j=n
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(i,k-1)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( a( i+j*lda ) )
! a(k-1,k-1)
s = s + aa
work( i ) = work( i ) + s
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
else
! ilu=1
do i = k, n - 1
work( i ) = zero
end do
! j=0 is special :process col a(k:n-1,k)
s = abs( a( 0_${ik}$ ) )
! a(k,k)
do i = 1, k - 1
aa = abs( a( i ) )
! a(k+i,k)
work( i+k ) = work( i+k ) + aa
s = s + aa
end do
work( k ) = work( k ) + s
do j = 1, k - 1
! process
s = zero
do i = 0, j - 2
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
aa = abs( a( i+j*lda ) )
! i=j-1 so process of a(j-1,j-1)
s = s + aa
work( j-1 ) = s
! is initialised here
i = i + 1_${ik}$
! i=j process a(j+k,j+k)
aa = abs( a( i+j*lda ) )
s = aa
do l = k + j + 1, n - 1
i = i + 1_${ik}$
aa = abs( a( i+j*lda ) )
! a(l,k+j)
s = s + aa
work( l ) = work( l ) + aa
end do
work( k+j ) = work( k+j ) + s
end do
! j=k is special :process col a(k,0:k-1)
s = zero
do i = 0, k - 2
aa = abs( a( i+j*lda ) )
! a(k,i)
work( i ) = work( i ) + aa
s = s + aa
end do
! i=k-1
aa = abs( a( i+j*lda ) )
! a(k-1,k-1)
s = s + aa
work( i ) = s
! done with col j=k+1
do j = k + 1, n
! process col j-1 of a = a(j-1,0:k-1)
s = zero
do i = 0, k - 1
aa = abs( a( i+j*lda ) )
! a(j-1,i)
work( i ) = work( i ) + aa
s = s + aa
end do
work( j-1 ) = work( j-1 ) + s
end do
value = work( 0_${ik}$ )
do i = 1, n-1
temp = work( i )
if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp
end do
end if
end if
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
k = ( n+1 ) / 2_${ik}$
scale = zero
s = one
if( noe==1_${ik}$ ) then
! n is odd
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 3
call stdlib${ii}$_${ri}$lassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(k,0)
end do
do j = 0, k - 1
call stdlib${ii}$_${ri}$lassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_${ri}$lassq( k-1, a( k ), lda+1, scale, s )
! tri l at a(k,0)
call stdlib${ii}$_${ri}$lassq( k, a( k-1 ), lda+1, scale, s )
! tri u at a(k-1,0)
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_${ri}$lassq( n-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! trap l at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+( 1_${ik}$+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri l at a(0,0)
call stdlib${ii}$_${ri}$lassq( k-1, a( 0_${ik}$+lda ), lda+1, scale, s )
! tri u at a(0,1)
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**t is upper
do j = 1, k - 2
call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+( k+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k)
end do
do j = 0, k - 2
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_${ri}$lassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1_${ik}$,scale, s )
! l at a(0,k-1)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_${ri}$lassq( k-1, a( 0_${ik}$+k*lda ), lda+1, scale, s )
! tri u at a(0,k)
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+( k-1 )*lda ), lda+1, scale, s )
! tri l at a(0,k-1)
else
! a**t is lower
do j = 1, k - 1
call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
do j = k, n - 1
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k-1 rect. at a(0,k)
end do
do j = 0, k - 3
call stdlib${ii}$_${ri}$lassq( k-j-2, a( j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(1,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri u at a(0,0)
call stdlib${ii}$_${ri}$lassq( k-1, a( 1_${ik}$ ), lda+1, scale, s )
! tri l at a(1,0)
end if
end if
else
! n is even
if( ifm==1_${ik}$ ) then
! a is normal
if( ilu==0_${ik}$ ) then
! a is upper
do j = 0, k - 2
call stdlib${ii}$_${ri}$lassq( k-j-1, a( k+j+2+j*lda ), 1_${ik}$, scale, s )
! l at a(k+1,0)
end do
do j = 0, k - 1
call stdlib${ii}$_${ri}$lassq( k+j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! trap u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_${ri}$lassq( k, a( k+1 ), lda+1, scale, s )
! tri l at a(k+1,0)
call stdlib${ii}$_${ri}$lassq( k, a( k ), lda+1, scale, s )
! tri u at a(k,0)
else
! ilu=1
do j = 0, k - 1
call stdlib${ii}$_${ri}$lassq( n-j-1, a( j+2+j*lda ), 1_${ik}$, scale, s )
! trap l at a(1,0)
end do
do j = 1, k - 1
call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! u at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_${ri}$lassq( k, a( 1_${ik}$ ), lda+1, scale, s )
! tri l at a(1,0)
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri u at a(0,0)
end if
else
! a is xpose
if( ilu==0_${ik}$ ) then
! a**t is upper
do j = 1, k - 1
call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+( k+1+j )*lda ), 1_${ik}$, scale, s )
! u at a(0,k+1)
end do
do j = 0, k - 1
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,0)
end do
do j = 0, k - 2
call stdlib${ii}$_${ri}$lassq( k-j-1, a( j+1+( j+k )*lda ), 1_${ik}$, scale,s )
! l at a(0,k)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+( k+1 )*lda ), lda+1, scale, s )
! tri u at a(0,k+1)
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+k*lda ), lda+1, scale, s )
! tri l at a(0,k)
else
! a**t is lower
do j = 1, k - 1
call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+( j+1 )*lda ), 1_${ik}$, scale, s )
! u at a(0,1)
end do
do j = k + 1, n
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s )
! k by k rect. at a(0,k+1)
end do
do j = 0, k - 2
call stdlib${ii}$_${ri}$lassq( k-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s )
! l at a(0,0)
end do
s = s + s
! double s for the off diagonal elements
call stdlib${ii}$_${ri}$lassq( k, a( lda ), lda+1, scale, s )
! tri l at a(0,1)
call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$ ), lda+1, scale, s )
! tri u at a(0,0)
end if
end if
end if
value = scale*sqrt( s )
end if
stdlib${ii}$_${ri}$lansf = value
return
end function stdlib${ii}$_${ri}$lansf
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clanhp( norm, uplo, n, ap, work )
!! CLANHP returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex hermitian matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k
real(sp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
k = 0_${ik}$
do j = 1, n
do i = k + 1, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + j
sum = abs( real( ap( k ),KIND=sp) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
k = 1_${ik}$
do j = 1, n
sum = abs( real( ap( k ),KIND=sp) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
do i = k + 1, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
value = zero
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
work( j ) = sum + abs( real( ap( k ),KIND=sp) )
k = k + 1_${ik}$
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( real( ap( k ),KIND=sp) )
k = k + 1_${ik}$
do i = j + 1, n
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
k = 2_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_classq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
do j = 1, n - 1
call stdlib${ii}$_classq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
sum = 2_${ik}$*sum
k = 1_${ik}$
do i = 1, n
if( real( ap( k ),KIND=sp)/=zero ) then
absa = abs( real( ap( k ),KIND=sp) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( stdlib_lsame( uplo, 'U' ) ) then
k = k + i + 1_${ik}$
else
k = k + n - i + 1_${ik}$
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_clanhp = value
return
end function stdlib${ii}$_clanhp
real(dp) module function stdlib${ii}$_zlanhp( norm, uplo, n, ap, work )
!! ZLANHP returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex hermitian matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k
real(dp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
k = 0_${ik}$
do j = 1, n
do i = k + 1, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + j
sum = abs( real( ap( k ),KIND=dp) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
k = 1_${ik}$
do j = 1, n
sum = abs( real( ap( k ),KIND=dp) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
do i = k + 1, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
value = zero
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
work( j ) = sum + abs( real( ap( k ),KIND=dp) )
k = k + 1_${ik}$
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( real( ap( k ),KIND=dp) )
k = k + 1_${ik}$
do i = j + 1, n
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
k = 2_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_zlassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
do j = 1, n - 1
call stdlib${ii}$_zlassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
sum = 2_${ik}$*sum
k = 1_${ik}$
do i = 1, n
if( real( ap( k ),KIND=dp)/=zero ) then
absa = abs( real( ap( k ),KIND=dp) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( stdlib_lsame( uplo, 'U' ) ) then
k = k + i + 1_${ik}$
else
k = k + n - i + 1_${ik}$
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlanhp = value
return
end function stdlib${ii}$_zlanhp
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lanhp( norm, uplo, n, ap, work )
!! ZLANHP: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex hermitian matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k
real(${ck}$) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
k = 0_${ik}$
do j = 1, n
do i = k + 1, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
k = k + j
sum = abs( real( ap( k ),KIND=${ck}$) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
k = 1_${ik}$
do j = 1, n
sum = abs( real( ap( k ),KIND=${ck}$) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
do i = k + 1, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
value = zero
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
work( j ) = sum + abs( real( ap( k ),KIND=${ck}$) )
k = k + 1_${ik}$
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( real( ap( k ),KIND=${ck}$) )
k = k + 1_${ik}$
do i = j + 1, n
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
k = 2_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_${ci}$lassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
do j = 1, n - 1
call stdlib${ii}$_${ci}$lassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
sum = 2_${ik}$*sum
k = 1_${ik}$
do i = 1, n
if( real( ap( k ),KIND=${ck}$)/=zero ) then
absa = abs( real( ap( k ),KIND=${ck}$) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( stdlib_lsame( uplo, 'U' ) ) then
k = k + i + 1_${ik}$
else
k = k + n - i + 1_${ik}$
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lanhp = value
return
end function stdlib${ii}$_${ci}$lanhp
#:endif
#:endfor
real(sp) module function stdlib${ii}$_slansp( norm, uplo, n, ap, work )
!! SLANSP returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(in) :: ap(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k
real(sp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
k = 1_${ik}$
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + j
end do
else
k = 1_${ik}$
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
work( j ) = sum + abs( ap( k ) )
k = k + 1_${ik}$
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ap( k ) )
k = k + 1_${ik}$
do i = j + 1, n
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
k = 2_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_slassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
do j = 1, n - 1
call stdlib${ii}$_slassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
sum = 2_${ik}$*sum
k = 1_${ik}$
do i = 1, n
if( ap( k )/=zero ) then
absa = abs( ap( k ) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( stdlib_lsame( uplo, 'U' ) ) then
k = k + i + 1_${ik}$
else
k = k + n - i + 1_${ik}$
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_slansp = value
return
end function stdlib${ii}$_slansp
real(dp) module function stdlib${ii}$_dlansp( norm, uplo, n, ap, work )
!! DLANSP returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(in) :: ap(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k
real(dp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
k = 1_${ik}$
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + j
end do
else
k = 1_${ik}$
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
work( j ) = sum + abs( ap( k ) )
k = k + 1_${ik}$
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ap( k ) )
k = k + 1_${ik}$
do i = j + 1, n
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
k = 2_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_dlassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
do j = 1, n - 1
call stdlib${ii}$_dlassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
sum = 2_${ik}$*sum
k = 1_${ik}$
do i = 1, n
if( ap( k )/=zero ) then
absa = abs( ap( k ) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( stdlib_lsame( uplo, 'U' ) ) then
k = k + i + 1_${ik}$
else
k = k + n - i + 1_${ik}$
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_dlansp = value
return
end function stdlib${ii}$_dlansp
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$lansp( norm, uplo, n, ap, work )
!! DLANSP: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(in) :: ap(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k
real(${rk}$) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
k = 1_${ik}$
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
k = k + j
end do
else
k = 1_${ik}$
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
work( j ) = sum + abs( ap( k ) )
k = k + 1_${ik}$
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ap( k ) )
k = k + 1_${ik}$
do i = j + 1, n
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
k = 2_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_${ri}$lassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
do j = 1, n - 1
call stdlib${ii}$_${ri}$lassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
sum = 2_${ik}$*sum
k = 1_${ik}$
do i = 1, n
if( ap( k )/=zero ) then
absa = abs( ap( k ) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( stdlib_lsame( uplo, 'U' ) ) then
k = k + i + 1_${ik}$
else
k = k + n - i + 1_${ik}$
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$lansp = value
return
end function stdlib${ii}$_${ri}$lansp
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clansp( norm, uplo, n, ap, work )
!! CLANSP returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex symmetric matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k
real(sp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
k = 1_${ik}$
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + j
end do
else
k = 1_${ik}$
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
work( j ) = sum + abs( ap( k ) )
k = k + 1_${ik}$
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ap( k ) )
k = k + 1_${ik}$
do i = j + 1, n
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
k = 2_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_classq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
do j = 1, n - 1
call stdlib${ii}$_classq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
sum = 2_${ik}$*sum
k = 1_${ik}$
do i = 1, n
if( real( ap( k ),KIND=sp)/=zero ) then
absa = abs( real( ap( k ),KIND=sp) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( aimag( ap( k ) )/=zero ) then
absa = abs( aimag( ap( k ) ) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( stdlib_lsame( uplo, 'U' ) ) then
k = k + i + 1_${ik}$
else
k = k + n - i + 1_${ik}$
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_clansp = value
return
end function stdlib${ii}$_clansp
real(dp) module function stdlib${ii}$_zlansp( norm, uplo, n, ap, work )
!! ZLANSP returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex symmetric matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k
real(dp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
k = 1_${ik}$
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + j
end do
else
k = 1_${ik}$
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
work( j ) = sum + abs( ap( k ) )
k = k + 1_${ik}$
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ap( k ) )
k = k + 1_${ik}$
do i = j + 1, n
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
k = 2_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_zlassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
do j = 1, n - 1
call stdlib${ii}$_zlassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
sum = 2_${ik}$*sum
k = 1_${ik}$
do i = 1, n
if( real( ap( k ),KIND=dp)/=zero ) then
absa = abs( real( ap( k ),KIND=dp) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( aimag( ap( k ) )/=zero ) then
absa = abs( aimag( ap( k ) ) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( stdlib_lsame( uplo, 'U' ) ) then
k = k + i + 1_${ik}$
else
k = k + n - i + 1_${ik}$
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlansp = value
return
end function stdlib${ii}$_zlansp
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lansp( norm, uplo, n, ap, work )
!! ZLANSP: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex symmetric matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, k
real(${ck}$) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
k = 1_${ik}$
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
k = k + j
end do
else
k = 1_${ik}$
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
work( j ) = sum + abs( ap( k ) )
k = k + 1_${ik}$
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ap( k ) )
k = k + 1_${ik}$
do i = j + 1, n
absa = abs( ap( k ) )
sum = sum + absa
work( i ) = work( i ) + absa
k = k + 1_${ik}$
end do
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
k = 2_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_${ci}$lassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
do j = 1, n - 1
call stdlib${ii}$_${ci}$lassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
sum = 2_${ik}$*sum
k = 1_${ik}$
do i = 1, n
if( real( ap( k ),KIND=${ck}$)/=zero ) then
absa = abs( real( ap( k ),KIND=${ck}$) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( aimag( ap( k ) )/=zero ) then
absa = abs( aimag( ap( k ) ) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
if( stdlib_lsame( uplo, 'U' ) ) then
k = k + i + 1_${ik}$
else
k = k + n - i + 1_${ik}$
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lansp = value
return
end function stdlib${ii}$_${ci}$lansp
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clanhb( norm, uplo, n, k, ab, ldab,work )
!! CLANHB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n hermitian band matrix A, with k super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
real(sp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
sum = abs( real( ab( k+1, j ),KIND=sp) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do j = 1, n
sum = abs( real( ab( 1_${ik}$, j ),KIND=sp) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
do i = 2, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( real( ab( k+1, j ),KIND=sp) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( real( ab( 1_${ik}$, j ),KIND=sp) )
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( k>0_${ik}$ ) then
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_classq( min( j-1, k ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
l = k + 1_${ik}$
else
do j = 1, n - 1
call stdlib${ii}$_classq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
l = 1_${ik}$
end if
sum = 2_${ik}$*sum
else
l = 1_${ik}$
end if
do j = 1, n
if( real( ab( l, j ),KIND=sp)/=zero ) then
absa = abs( real( ab( l, j ),KIND=sp) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_clanhb = value
return
end function stdlib${ii}$_clanhb
real(dp) module function stdlib${ii}$_zlanhb( norm, uplo, n, k, ab, ldab,work )
!! ZLANHB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n hermitian band matrix A, with k super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
real(dp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
sum = abs( real( ab( k+1, j ),KIND=dp) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do j = 1, n
sum = abs( real( ab( 1_${ik}$, j ),KIND=dp) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
do i = 2, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( real( ab( k+1, j ),KIND=dp) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( real( ab( 1_${ik}$, j ),KIND=dp) )
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( k>0_${ik}$ ) then
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_zlassq( min( j-1, k ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
l = k + 1_${ik}$
else
do j = 1, n - 1
call stdlib${ii}$_zlassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
l = 1_${ik}$
end if
sum = 2_${ik}$*sum
else
l = 1_${ik}$
end if
do j = 1, n
if( real( ab( l, j ),KIND=dp)/=zero ) then
absa = abs( real( ab( l, j ),KIND=dp) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlanhb = value
return
end function stdlib${ii}$_zlanhb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lanhb( norm, uplo, n, k, ab, ldab,work )
!! ZLANHB: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n hermitian band matrix A, with k super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
real(${ck}$) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
sum = abs( real( ab( k+1, j ),KIND=${ck}$) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do j = 1, n
sum = abs( real( ab( 1_${ik}$, j ),KIND=${ck}$) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
do i = 2, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( real( ab( k+1, j ),KIND=${ck}$) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( real( ab( 1_${ik}$, j ),KIND=${ck}$) )
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( k>0_${ik}$ ) then
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_${ci}$lassq( min( j-1, k ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
l = k + 1_${ik}$
else
do j = 1, n - 1
call stdlib${ii}$_${ci}$lassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
l = 1_${ik}$
end if
sum = 2_${ik}$*sum
else
l = 1_${ik}$
end if
do j = 1, n
if( real( ab( l, j ),KIND=${ck}$)/=zero ) then
absa = abs( real( ab( l, j ),KIND=${ck}$) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lanhb = value
return
end function stdlib${ii}$_${ci}$lanhb
#:endif
#:endfor
real(sp) module function stdlib${ii}$_slansb( norm, uplo, n, k, ab, ldab,work )
!! SLANSB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n symmetric band matrix A, with k super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
real(sp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( ab( k+1, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ab( 1_${ik}$, j ) )
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( k>0_${ik}$ ) then
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_slassq( min( j-1, k ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
l = k + 1_${ik}$
else
do j = 1, n - 1
call stdlib${ii}$_slassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
l = 1_${ik}$
end if
sum = 2_${ik}$*sum
else
l = 1_${ik}$
end if
call stdlib${ii}$_slassq( n, ab( l, 1_${ik}$ ), ldab, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_slansb = value
return
end function stdlib${ii}$_slansb
real(dp) module function stdlib${ii}$_dlansb( norm, uplo, n, k, ab, ldab,work )
!! DLANSB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n symmetric band matrix A, with k super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
real(dp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( ab( k+1, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ab( 1_${ik}$, j ) )
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( k>0_${ik}$ ) then
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_dlassq( min( j-1, k ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
l = k + 1_${ik}$
else
do j = 1, n - 1
call stdlib${ii}$_dlassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
l = 1_${ik}$
end if
sum = 2_${ik}$*sum
else
l = 1_${ik}$
end if
call stdlib${ii}$_dlassq( n, ab( l, 1_${ik}$ ), ldab, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_dlansb = value
return
end function stdlib${ii}$_dlansb
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$lansb( norm, uplo, n, k, ab, ldab,work )
!! DLANSB: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n symmetric band matrix A, with k super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
real(${rk}$) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( ab( k+1, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ab( 1_${ik}$, j ) )
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( k>0_${ik}$ ) then
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_${ri}$lassq( min( j-1, k ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
l = k + 1_${ik}$
else
do j = 1, n - 1
call stdlib${ii}$_${ri}$lassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
l = 1_${ik}$
end if
sum = 2_${ik}$*sum
else
l = 1_${ik}$
end if
call stdlib${ii}$_${ri}$lassq( n, ab( l, 1_${ik}$ ), ldab, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$lansb = value
return
end function stdlib${ii}$_${ri}$lansb
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clansb( norm, uplo, n, k, ab, ldab,work )
!! CLANSB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n symmetric band matrix A, with k super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
real(sp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( ab( k+1, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ab( 1_${ik}$, j ) )
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( k>0_${ik}$ ) then
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_classq( min( j-1, k ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
l = k + 1_${ik}$
else
do j = 1, n - 1
call stdlib${ii}$_classq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
l = 1_${ik}$
end if
sum = 2_${ik}$*sum
else
l = 1_${ik}$
end if
call stdlib${ii}$_classq( n, ab( l, 1_${ik}$ ), ldab, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_clansb = value
return
end function stdlib${ii}$_clansb
real(dp) module function stdlib${ii}$_zlansb( norm, uplo, n, k, ab, ldab,work )
!! ZLANSB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n symmetric band matrix A, with k super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
real(dp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( ab( k+1, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ab( 1_${ik}$, j ) )
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( k>0_${ik}$ ) then
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_zlassq( min( j-1, k ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
l = k + 1_${ik}$
else
do j = 1, n - 1
call stdlib${ii}$_zlassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
l = 1_${ik}$
end if
sum = 2_${ik}$*sum
else
l = 1_${ik}$
end if
call stdlib${ii}$_zlassq( n, ab( l, 1_${ik}$ ), ldab, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlansb = value
return
end function stdlib${ii}$_zlansb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lansb( norm, uplo, n, k, ab, ldab,work )
!! ZLANSB: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n symmetric band matrix A, with k super-diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, l
real(${ck}$) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( ab( k+1, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( ab( 1_${ik}$, j ) )
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
absa = abs( ab( l+i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( k>0_${ik}$ ) then
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_${ci}$lassq( min( j-1, k ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
l = k + 1_${ik}$
else
do j = 1, n - 1
call stdlib${ii}$_${ci}$lassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
l = 1_${ik}$
end if
sum = 2_${ik}$*sum
else
l = 1_${ik}$
end if
call stdlib${ii}$_${ci}$lassq( n, ab( l, 1_${ik}$ ), ldab, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lansb = value
return
end function stdlib${ii}$_${ci}$lansb
#:endif
#:endfor
pure real(sp) module function stdlib${ii}$_clanht( norm, n, d, e )
!! CLANHT returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex Hermitian tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(in) :: d(*)
complex(sp), intent(in) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: anorm, scale, sum
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
sum = abs( d( i ) )
if( anorm < sum .or. stdlib${ii}$_sisnan( sum ) ) anorm = sum
sum = abs( e( i ) )
if( anorm < sum .or. stdlib${ii}$_sisnan( sum ) ) anorm = sum
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' .or.stdlib_lsame( norm, 'I' ) ) &
then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( e( 1_${ik}$ ) )
sum = abs( e( n-1 ) )+abs( d( n ) )
if( anorm < sum .or. stdlib${ii}$_sisnan( sum ) ) anorm = sum
do i = 2, n - 1
sum = abs( d( i ) )+abs( e( i ) )+abs( e( i-1 ) )
if( anorm < sum .or. stdlib${ii}$_sisnan( sum ) ) anorm = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( n>1_${ik}$ ) then
call stdlib${ii}$_classq( n-1, e, 1_${ik}$, scale, sum )
sum = 2_${ik}$*sum
end if
call stdlib${ii}$_slassq( n, d, 1_${ik}$, scale, sum )
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_clanht = anorm
return
end function stdlib${ii}$_clanht
pure real(dp) module function stdlib${ii}$_zlanht( norm, n, d, e )
!! ZLANHT returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex Hermitian tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(in) :: d(*)
complex(dp), intent(in) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: anorm, scale, sum
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
sum = abs( d( i ) )
if( anorm < sum .or. stdlib${ii}$_disnan( sum ) ) anorm = sum
sum = abs( e( i ) )
if( anorm < sum .or. stdlib${ii}$_disnan( sum ) ) anorm = sum
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' .or.stdlib_lsame( norm, 'I' ) ) &
then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( e( 1_${ik}$ ) )
sum = abs( e( n-1 ) )+abs( d( n ) )
if( anorm < sum .or. stdlib${ii}$_disnan( sum ) ) anorm = sum
do i = 2, n - 1
sum = abs( d( i ) )+abs( e( i ) )+abs( e( i-1 ) )
if( anorm < sum .or. stdlib${ii}$_disnan( sum ) ) anorm = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( n>1_${ik}$ ) then
call stdlib${ii}$_zlassq( n-1, e, 1_${ik}$, scale, sum )
sum = 2_${ik}$*sum
end if
call stdlib${ii}$_dlassq( n, d, 1_${ik}$, scale, sum )
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_zlanht = anorm
return
end function stdlib${ii}$_zlanht
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure real(${ck}$) module function stdlib${ii}$_${ci}$lanht( norm, n, d, e )
!! ZLANHT: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex Hermitian tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${ck}$), intent(in) :: d(*)
complex(${ck}$), intent(in) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${ck}$) :: anorm, scale, sum
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
sum = abs( d( i ) )
if( anorm < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) anorm = sum
sum = abs( e( i ) )
if( anorm < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) anorm = sum
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' .or.stdlib_lsame( norm, 'I' ) ) &
then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( e( 1_${ik}$ ) )
sum = abs( e( n-1 ) )+abs( d( n ) )
if( anorm < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) anorm = sum
do i = 2, n - 1
sum = abs( d( i ) )+abs( e( i ) )+abs( e( i-1 ) )
if( anorm < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) anorm = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( n>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lassq( n-1, e, 1_${ik}$, scale, sum )
sum = 2_${ik}$*sum
end if
call stdlib${ii}$_${c2ri(ci)}$lassq( n, d, 1_${ik}$, scale, sum )
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lanht = anorm
return
end function stdlib${ii}$_${ci}$lanht
#:endif
#:endfor
pure real(sp) module function stdlib${ii}$_slanst( norm, n, d, e )
!! SLANST returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(in) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: anorm, scale, sum
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
sum = abs( d( i ) )
if( anorm < sum .or. stdlib${ii}$_sisnan( sum ) ) anorm = sum
sum = abs( e( i ) )
if( anorm < sum .or. stdlib${ii}$_sisnan( sum ) ) anorm = sum
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' .or.stdlib_lsame( norm, 'I' ) ) &
then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( e( 1_${ik}$ ) )
sum = abs( e( n-1 ) )+abs( d( n ) )
if( anorm < sum .or. stdlib${ii}$_sisnan( sum ) ) anorm = sum
do i = 2, n - 1
sum = abs( d( i ) )+abs( e( i ) )+abs( e( i-1 ) )
if( anorm < sum .or. stdlib${ii}$_sisnan( sum ) ) anorm = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( n>1_${ik}$ ) then
call stdlib${ii}$_slassq( n-1, e, 1_${ik}$, scale, sum )
sum = 2_${ik}$*sum
end if
call stdlib${ii}$_slassq( n, d, 1_${ik}$, scale, sum )
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_slanst = anorm
return
end function stdlib${ii}$_slanst
pure real(dp) module function stdlib${ii}$_dlanst( norm, n, d, e )
!! DLANST returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(in) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: anorm, scale, sum
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
sum = abs( d( i ) )
if( anorm < sum .or. stdlib${ii}$_disnan( sum ) ) anorm = sum
sum = abs( e( i ) )
if( anorm < sum .or. stdlib${ii}$_disnan( sum ) ) anorm = sum
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' .or.stdlib_lsame( norm, 'I' ) ) &
then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( e( 1_${ik}$ ) )
sum = abs( e( n-1 ) )+abs( d( n ) )
if( anorm < sum .or. stdlib${ii}$_disnan( sum ) ) anorm = sum
do i = 2, n - 1
sum = abs( d( i ) )+abs( e( i ) )+abs( e( i-1 ) )
if( anorm < sum .or. stdlib${ii}$_disnan( sum ) ) anorm = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( n>1_${ik}$ ) then
call stdlib${ii}$_dlassq( n-1, e, 1_${ik}$, scale, sum )
sum = 2_${ik}$*sum
end if
call stdlib${ii}$_dlassq( n, d, 1_${ik}$, scale, sum )
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_dlanst = anorm
return
end function stdlib${ii}$_dlanst
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure real(${rk}$) module function stdlib${ii}$_${ri}$lanst( norm, n, d, e )
!! DLANST: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric tridiagonal matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(in) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${rk}$) :: anorm, scale, sum
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
anorm = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
anorm = abs( d( n ) )
do i = 1, n - 1
sum = abs( d( i ) )
if( anorm < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) anorm = sum
sum = abs( e( i ) )
if( anorm < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) anorm = sum
end do
else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' .or.stdlib_lsame( norm, 'I' ) ) &
then
! find norm1(a).
if( n==1_${ik}$ ) then
anorm = abs( d( 1_${ik}$ ) )
else
anorm = abs( d( 1_${ik}$ ) )+abs( e( 1_${ik}$ ) )
sum = abs( e( n-1 ) )+abs( d( n ) )
if( anorm < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) anorm = sum
do i = 2, n - 1
sum = abs( d( i ) )+abs( e( i ) )+abs( e( i-1 ) )
if( anorm < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) anorm = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( n>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lassq( n-1, e, 1_${ik}$, scale, sum )
sum = 2_${ik}$*sum
end if
call stdlib${ii}$_${ri}$lassq( n, d, 1_${ik}$, scale, sum )
anorm = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$lanst = anorm
return
end function stdlib${ii}$_${ri}$lanst
#:endif
#:endfor
real(sp) module function stdlib${ii}$_slantr( norm, uplo, diag, m, n, a, lda,work )
!! SLANTR returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! trapezoidal or triangular matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j
real(sp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j-1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j + 1, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( ( udiag ) .and. ( j<=m ) ) then
sum = one
do i = 1, j - 1
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = 1, min( m, j )
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = j + 1, m
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = j, m
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, m
work( i ) = one
end do
do j = 1, n
do i = 1, min( m, j-1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, min( m, j )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, min( m, n )
work( i ) = one
end do
do i = n + 1, m
work( i ) = zero
end do
do j = 1, n
do i = j + 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = j, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
end if
value = zero
do i = 1, m
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 2, n
call stdlib${ii}$_slassq( min( m, j-1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_slassq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 1, n
call stdlib${ii}$_slassq( m-j, a( min( m, j+1 ), j ), 1_${ik}$, scale,sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_slassq( m-j+1, a( j, j ), 1_${ik}$, scale, sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_slantr = value
return
end function stdlib${ii}$_slantr
real(dp) module function stdlib${ii}$_dlantr( norm, uplo, diag, m, n, a, lda,work )
!! DLANTR returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! trapezoidal or triangular matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j
real(dp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j-1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j + 1, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( ( udiag ) .and. ( j<=m ) ) then
sum = one
do i = 1, j - 1
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = 1, min( m, j )
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = j + 1, m
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = j, m
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, m
work( i ) = one
end do
do j = 1, n
do i = 1, min( m, j-1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, min( m, j )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, min( m, n )
work( i ) = one
end do
do i = n + 1, m
work( i ) = zero
end do
do j = 1, n
do i = j + 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = j, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
end if
value = zero
do i = 1, m
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 2, n
call stdlib${ii}$_dlassq( min( m, j-1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_dlassq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 1, n
call stdlib${ii}$_dlassq( m-j, a( min( m, j+1 ), j ), 1_${ik}$, scale,sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_dlassq( m-j+1, a( j, j ), 1_${ik}$, scale, sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_dlantr = value
return
end function stdlib${ii}$_dlantr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$lantr( norm, uplo, diag, m, n, a, lda,work )
!! DLANTR: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! trapezoidal or triangular matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j
real(${rk}$) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j-1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j + 1, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( ( udiag ) .and. ( j<=m ) ) then
sum = one
do i = 1, j - 1
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = 1, min( m, j )
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = j + 1, m
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = j, m
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, m
work( i ) = one
end do
do j = 1, n
do i = 1, min( m, j-1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, min( m, j )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, min( m, n )
work( i ) = one
end do
do i = n + 1, m
work( i ) = zero
end do
do j = 1, n
do i = j + 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = j, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
end if
value = zero
do i = 1, m
sum = work( i )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 2, n
call stdlib${ii}$_${ri}$lassq( min( m, j-1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ri}$lassq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 1, n
call stdlib${ii}$_${ri}$lassq( m-j, a( min( m, j+1 ), j ), 1_${ik}$, scale,sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ri}$lassq( m-j+1, a( j, j ), 1_${ik}$, scale, sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$lantr = value
return
end function stdlib${ii}$_${ri}$lantr
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clantr( norm, uplo, diag, m, n, a, lda,work )
!! CLANTR returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! trapezoidal or triangular matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j
real(sp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j-1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j + 1, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( ( udiag ) .and. ( j<=m ) ) then
sum = one
do i = 1, j - 1
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = 1, min( m, j )
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = j + 1, m
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = j, m
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, m
work( i ) = one
end do
do j = 1, n
do i = 1, min( m, j-1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, min( m, j )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, min( m, n )
work( i ) = one
end do
do i = n + 1, m
work( i ) = zero
end do
do j = 1, n
do i = j + 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = j, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
end if
value = zero
do i = 1, m
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 2, n
call stdlib${ii}$_classq( min( m, j-1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_classq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 1, n
call stdlib${ii}$_classq( m-j, a( min( m, j+1 ), j ), 1_${ik}$, scale,sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_classq( m-j+1, a( j, j ), 1_${ik}$, scale, sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_clantr = value
return
end function stdlib${ii}$_clantr
real(dp) module function stdlib${ii}$_zlantr( norm, uplo, diag, m, n, a, lda,work )
!! ZLANTR returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! trapezoidal or triangular matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j
real(dp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j-1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j + 1, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( ( udiag ) .and. ( j<=m ) ) then
sum = one
do i = 1, j - 1
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = 1, min( m, j )
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = j + 1, m
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = j, m
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, m
work( i ) = one
end do
do j = 1, n
do i = 1, min( m, j-1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, min( m, j )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, min( m, n )
work( i ) = one
end do
do i = n + 1, m
work( i ) = zero
end do
do j = 1, n
do i = j + 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = j, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
end if
value = zero
do i = 1, m
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 2, n
call stdlib${ii}$_zlassq( min( m, j-1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_zlassq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 1, n
call stdlib${ii}$_zlassq( m-j, a( min( m, j+1 ), j ), 1_${ik}$, scale,sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_zlassq( m-j+1, a( j, j ), 1_${ik}$, scale, sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlantr = value
return
end function stdlib${ii}$_zlantr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lantr( norm, uplo, diag, m, n, a, lda,work )
!! ZLANTR: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! trapezoidal or triangular matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j
real(${ck}$) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( min( m, n )==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j-1 )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j + 1, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, min( m, j )
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, m
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( ( udiag ) .and. ( j<=m ) ) then
sum = one
do i = 1, j - 1
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = 1, min( m, j )
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = j + 1, m
sum = sum + abs( a( i, j ) )
end do
else
sum = zero
do i = j, m
sum = sum + abs( a( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, m
work( i ) = one
end do
do j = 1, n
do i = 1, min( m, j-1 )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = 1, min( m, j )
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, min( m, n )
work( i ) = one
end do
do i = n + 1, m
work( i ) = zero
end do
do j = 1, n
do i = j + 1, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
else
do i = 1, m
work( i ) = zero
end do
do j = 1, n
do i = j, m
work( i ) = work( i ) + abs( a( i, j ) )
end do
end do
end if
end if
value = zero
do i = 1, m
sum = work( i )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 2, n
call stdlib${ii}$_${ci}$lassq( min( m, j-1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ci}$lassq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = min( m, n )
do j = 1, n
call stdlib${ii}$_${ci}$lassq( m-j, a( min( m, j+1 ), j ), 1_${ik}$, scale,sum )
end do
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ci}$lassq( m-j+1, a( j, j ), 1_${ik}$, scale, sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lantr = value
return
end function stdlib${ii}$_${ci}$lantr
#:endif
#:endfor
real(sp) module function stdlib${ii}$_slantp( norm, uplo, diag, n, ap, work )
!! SLANTP returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! triangular matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(in) :: ap(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, k
real(sp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = 1_${ik}$
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 2
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k + 1, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
k = 1_${ik}$
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = k, k + j - 2
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + j - 1
sum = sum + abs( ap( i ) )
end do
end if
k = k + j
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = k + 1, k + n - j
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + n - j
sum = sum + abs( ap( i ) )
end do
end if
k = k + n - j + 1_${ik}$
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
do i = 1, j - 1
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
k = k + 1_${ik}$
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, j
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
k = k + 1_${ik}$
do i = j + 1, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = j, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
end if
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 2, n
call stdlib${ii}$_slassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_slassq( j, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 1, n - 1
call stdlib${ii}$_slassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_slassq( n-j+1, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_slantp = value
return
end function stdlib${ii}$_slantp
real(dp) module function stdlib${ii}$_dlantp( norm, uplo, diag, n, ap, work )
!! DLANTP returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! triangular matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(in) :: ap(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, k
real(dp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = 1_${ik}$
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 2
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k + 1, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
k = 1_${ik}$
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = k, k + j - 2
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + j - 1
sum = sum + abs( ap( i ) )
end do
end if
k = k + j
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = k + 1, k + n - j
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + n - j
sum = sum + abs( ap( i ) )
end do
end if
k = k + n - j + 1_${ik}$
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
do i = 1, j - 1
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
k = k + 1_${ik}$
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, j
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
k = k + 1_${ik}$
do i = j + 1, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = j, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
end if
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 2, n
call stdlib${ii}$_dlassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_dlassq( j, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 1, n - 1
call stdlib${ii}$_dlassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_dlassq( n-j+1, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_dlantp = value
return
end function stdlib${ii}$_dlantp
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$lantp( norm, uplo, diag, n, ap, work )
!! DLANTP: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! triangular matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(in) :: ap(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, k
real(${rk}$) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = 1_${ik}$
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 2
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k + 1, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
k = 1_${ik}$
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = k, k + j - 2
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + j - 1
sum = sum + abs( ap( i ) )
end do
end if
k = k + j
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = k + 1, k + n - j
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + n - j
sum = sum + abs( ap( i ) )
end do
end if
k = k + n - j + 1_${ik}$
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
do i = 1, j - 1
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
k = k + 1_${ik}$
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, j
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
k = k + 1_${ik}$
do i = j + 1, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = j, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
end if
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 2, n
call stdlib${ii}$_${ri}$lassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_${ri}$lassq( j, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 1, n - 1
call stdlib${ii}$_${ri}$lassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_${ri}$lassq( n-j+1, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$lantp = value
return
end function stdlib${ii}$_${ri}$lantp
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clantp( norm, uplo, diag, n, ap, work )
!! CLANTP returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! triangular matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, k
real(sp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = 1_${ik}$
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 2
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k + 1, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
k = 1_${ik}$
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = k, k + j - 2
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + j - 1
sum = sum + abs( ap( i ) )
end do
end if
k = k + j
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = k + 1, k + n - j
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + n - j
sum = sum + abs( ap( i ) )
end do
end if
k = k + n - j + 1_${ik}$
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
do i = 1, j - 1
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
k = k + 1_${ik}$
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, j
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
k = k + 1_${ik}$
do i = j + 1, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = j, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
end if
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 2, n
call stdlib${ii}$_classq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_classq( j, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 1, n - 1
call stdlib${ii}$_classq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_classq( n-j+1, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_clantp = value
return
end function stdlib${ii}$_clantp
real(dp) module function stdlib${ii}$_zlantp( norm, uplo, diag, n, ap, work )
!! ZLANTP returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! triangular matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, k
real(dp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = 1_${ik}$
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 2
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k + 1, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
k = 1_${ik}$
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = k, k + j - 2
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + j - 1
sum = sum + abs( ap( i ) )
end do
end if
k = k + j
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = k + 1, k + n - j
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + n - j
sum = sum + abs( ap( i ) )
end do
end if
k = k + n - j + 1_${ik}$
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
do i = 1, j - 1
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
k = k + 1_${ik}$
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, j
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
k = k + 1_${ik}$
do i = j + 1, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = j, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
end if
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 2, n
call stdlib${ii}$_zlassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_zlassq( j, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 1, n - 1
call stdlib${ii}$_zlassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_zlassq( n-j+1, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlantp = value
return
end function stdlib${ii}$_zlantp
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lantp( norm, uplo, diag, n, ap, work )
!! ZLANTP: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! triangular matrix A, supplied in packed form.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, k
real(${ck}$) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
k = 1_${ik}$
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 2
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k + 1, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = k, k + j - 1
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
k = k + j
end do
else
do j = 1, n
do i = k, k + n - j
sum = abs( ap( i ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
k = k + n - j + 1_${ik}$
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
k = 1_${ik}$
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = k, k + j - 2
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + j - 1
sum = sum + abs( ap( i ) )
end do
end if
k = k + j
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = k + 1, k + n - j
sum = sum + abs( ap( i ) )
end do
else
sum = zero
do i = k, k + n - j
sum = sum + abs( ap( i ) )
end do
end if
k = k + n - j + 1_${ik}$
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
k = 1_${ik}$
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
do i = 1, j - 1
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
k = k + 1_${ik}$
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = 1, j
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
k = k + 1_${ik}$
do i = j + 1, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
do i = j, n
work( i ) = work( i ) + abs( ap( k ) )
k = k + 1_${ik}$
end do
end do
end if
end if
value = zero
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 2, n
call stdlib${ii}$_${ci}$lassq( j-1, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_${ci}$lassq( j, ap( k ), 1_${ik}$, scale, sum )
k = k + j
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
k = 2_${ik}$
do j = 1, n - 1
call stdlib${ii}$_${ci}$lassq( n-j, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
else
scale = zero
sum = one
k = 1_${ik}$
do j = 1, n
call stdlib${ii}$_${ci}$lassq( n-j+1, ap( k ), 1_${ik}$, scale, sum )
k = k + n - j + 1_${ik}$
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lantp = value
return
end function stdlib${ii}$_${ci}$lantp
#:endif
#:endfor
real(sp) module function stdlib${ii}$_slantb( norm, uplo, diag, n, k, ab,ldab, work )
!! SLANTB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n triangular band matrix A, with ( k + 1 ) diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, l
real(sp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 2, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = max( k+2-j, 1 ), k
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = max( k+2-j, 1 ), k + 1
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = 2, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = 1, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
end if
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 2, n
call stdlib${ii}$_slassq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,&
sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_slassq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 1, n - 1
call stdlib${ii}$_slassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_slassq( min( n-j+1, k+1 ), ab( 1_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_slantb = value
return
end function stdlib${ii}$_slantb
real(dp) module function stdlib${ii}$_dlantb( norm, uplo, diag, n, k, ab,ldab, work )
!! DLANTB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n triangular band matrix A, with ( k + 1 ) diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, l
real(dp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 2, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = max( k+2-j, 1 ), k
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = max( k+2-j, 1 ), k + 1
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = 2, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = 1, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
end if
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 2, n
call stdlib${ii}$_dlassq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,&
sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_dlassq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 1, n - 1
call stdlib${ii}$_dlassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_dlassq( min( n-j+1, k+1 ), ab( 1_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_dlantb = value
return
end function stdlib${ii}$_dlantb
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$lantb( norm, uplo, diag, n, k, ab,ldab, work )
!! DLANTB: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n triangular band matrix A, with ( k + 1 ) diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, l
real(${rk}$) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 2, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = max( k+2-j, 1 ), k
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = max( k+2-j, 1 ), k + 1
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = 2, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = 1, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
end if
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 2, n
call stdlib${ii}$_${ri}$lassq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,&
sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ri}$lassq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 1, n - 1
call stdlib${ii}$_${ri}$lassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ri}$lassq( min( n-j+1, k+1 ), ab( 1_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$lantb = value
return
end function stdlib${ii}$_${ri}$lantb
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clantb( norm, uplo, diag, n, k, ab,ldab, work )
!! CLANTB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n triangular band matrix A, with ( k + 1 ) diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, l
real(sp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 2, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = max( k+2-j, 1 ), k
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = max( k+2-j, 1 ), k + 1
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = 2, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = 1, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
end if
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 2, n
call stdlib${ii}$_classq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,&
sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_classq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 1, n - 1
call stdlib${ii}$_classq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_classq( min( n-j+1, k+1 ), ab( 1_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_clantb = value
return
end function stdlib${ii}$_clantb
real(dp) module function stdlib${ii}$_zlantb( norm, uplo, diag, n, k, ab,ldab, work )
!! ZLANTB returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n triangular band matrix A, with ( k + 1 ) diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, l
real(dp) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 2, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = max( k+2-j, 1 ), k
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = max( k+2-j, 1 ), k + 1
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = 2, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = 1, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
end if
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 2, n
call stdlib${ii}$_zlassq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,&
sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_zlassq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 1, n - 1
call stdlib${ii}$_zlassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_zlassq( min( n-j+1, k+1 ), ab( 1_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlantb = value
return
end function stdlib${ii}$_zlantb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lantb( norm, uplo, diag, n, k, ab,ldab, work )
!! ZLANTB: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of an
!! n by n triangular band matrix A, with ( k + 1 ) diagonals.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: diag, norm, uplo
integer(${ik}$), intent(in) :: k, ldab, n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: udiag
integer(${ik}$) :: i, j, l
real(${ck}$) :: scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
if( stdlib_lsame( diag, 'U' ) ) then
value = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 2, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
end if
else
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = max( k+2-j, 1 ), k + 1
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = 1, min( n+1-j, k+1 )
sum = abs( ab( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
end if
end if
else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then
! find norm1(a).
value = zero
udiag = stdlib_lsame( diag, 'U' )
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
if( udiag ) then
sum = one
do i = max( k+2-j, 1 ), k
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = max( k+2-j, 1 ), k + 1
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do j = 1, n
if( udiag ) then
sum = one
do i = 2, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
else
sum = zero
do i = 1, min( n+1-j, k+1 )
sum = sum + abs( ab( i, j ) )
end do
end if
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end if
else if( stdlib_lsame( norm, 'I' ) ) then
! find normi(a).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j - 1
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = k + 1_${ik}$ - j
do i = max( 1, j-k ), j
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
do i = 1, n
work( i ) = one
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j + 1, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
l = 1_${ik}$ - j
do i = j, min( n, j+k )
work( i ) = work( i ) + abs( ab( l+i, j ) )
end do
end do
end if
end if
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
if( stdlib_lsame( uplo, 'U' ) ) then
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 2, n
call stdlib${ii}$_${ci}$lassq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,&
sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ci}$lassq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum )
end do
end if
else
if( stdlib_lsame( diag, 'U' ) ) then
scale = one
sum = n
if( k>0_${ik}$ ) then
do j = 1, n - 1
call stdlib${ii}$_${ci}$lassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
else
scale = zero
sum = one
do j = 1, n
call stdlib${ii}$_${ci}$lassq( min( n-j+1, k+1 ), ab( 1_${ik}$, j ), 1_${ik}$, scale,sum )
end do
end if
end if
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lantb = value
return
end function stdlib${ii}$_${ci}$lantb
#:endif
#:endfor
real(sp) module function stdlib${ii}$_slansy( norm, uplo, n, a, lda, work )
!! SLANSY returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, j
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, n
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( a( j, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( a( j, j ) )
do i = j + 1, n
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_slassq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
do j = 1, n - 1
call stdlib${ii}$_slassq( n-j, a( j+1, j ), 1_${ik}$, scale, sum )
end do
end if
sum = 2_${ik}$*sum
call stdlib${ii}$_slassq( n, a, lda+1, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_slansy = value
return
end function stdlib${ii}$_slansy
real(dp) module function stdlib${ii}$_dlansy( norm, uplo, n, a, lda, work )
!! DLANSY returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, j
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, n
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( a( j, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( a( j, j ) )
do i = j + 1, n
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_dlassq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
do j = 1, n - 1
call stdlib${ii}$_dlassq( n-j, a( j+1, j ), 1_${ik}$, scale, sum )
end do
end if
sum = 2_${ik}$*sum
call stdlib${ii}$_dlassq( n, a, lda+1, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_dlansy = value
return
end function stdlib${ii}$_dlansy
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$lansy( norm, uplo, n, a, lda, work )
!! DLANSY: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! real symmetric matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${rk}$) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, j
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, n
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( a( j, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( a( j, j ) )
do i = j + 1, n
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_${ri}$lassq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
do j = 1, n - 1
call stdlib${ii}$_${ri}$lassq( n-j, a( j+1, j ), 1_${ik}$, scale, sum )
end do
end if
sum = 2_${ik}$*sum
call stdlib${ii}$_${ri}$lassq( n, a, lda+1, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ri}$lansy = value
return
end function stdlib${ii}$_${ri}$lansy
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clansy( norm, uplo, n, a, lda, work )
!! CLANSY returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex symmetric matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, j
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, n
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( a( j, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( a( j, j ) )
do i = j + 1, n
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_classq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
do j = 1, n - 1
call stdlib${ii}$_classq( n-j, a( j+1, j ), 1_${ik}$, scale, sum )
end do
end if
sum = 2_${ik}$*sum
call stdlib${ii}$_classq( n, a, lda+1, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_clansy = value
return
end function stdlib${ii}$_clansy
real(dp) module function stdlib${ii}$_zlansy( norm, uplo, n, a, lda, work )
!! ZLANSY returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex symmetric matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, j
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, n
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( a( j, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( a( j, j ) )
do i = j + 1, n
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_zlassq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
do j = 1, n - 1
call stdlib${ii}$_zlassq( n-j, a( j+1, j ), 1_${ik}$, scale, sum )
end do
end if
sum = 2_${ik}$*sum
call stdlib${ii}$_zlassq( n, a, lda+1, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlansy = value
return
end function stdlib${ii}$_zlansy
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lansy( norm, uplo, n, a, lda, work )
!! ZLANSY: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex symmetric matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, j
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
else
do j = 1, n
do i = j, n
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is symmetric).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( a( j, j ) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( a( j, j ) )
do i = j + 1, n
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_${ci}$lassq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
do j = 1, n - 1
call stdlib${ii}$_${ci}$lassq( n-j, a( j+1, j ), 1_${ik}$, scale, sum )
end do
end if
sum = 2_${ik}$*sum
call stdlib${ii}$_${ci}$lassq( n, a, lda+1, scale, sum )
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lansy = value
return
end function stdlib${ii}$_${ci}$lansy
#:endif
#:endfor
real(sp) module function stdlib${ii}$_clanhe( norm, uplo, n, a, lda, work )
!! CLANHE returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex hermitian matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(out) :: work(*)
complex(sp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, j - 1
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
sum = abs( real( a( j, j ),KIND=sp) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do j = 1, n
sum = abs( real( a( j, j ),KIND=sp) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
do i = j + 1, n
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( real( a( j, j ),KIND=sp) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( real( a( j, j ),KIND=sp) )
do i = j + 1, n
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_classq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
do j = 1, n - 1
call stdlib${ii}$_classq( n-j, a( j+1, j ), 1_${ik}$, scale, sum )
end do
end if
sum = 2_${ik}$*sum
do i = 1, n
if( real( a( i, i ),KIND=sp)/=zero ) then
absa = abs( real( a( i, i ),KIND=sp) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_clanhe = value
return
end function stdlib${ii}$_clanhe
real(dp) module function stdlib${ii}$_zlanhe( norm, uplo, n, a, lda, work )
!! ZLANHE returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex hermitian matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(out) :: work(*)
complex(dp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, j - 1
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
sum = abs( real( a( j, j ),KIND=dp) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do j = 1, n
sum = abs( real( a( j, j ),KIND=dp) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
do i = j + 1, n
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( real( a( j, j ),KIND=dp) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( real( a( j, j ),KIND=dp) )
do i = j + 1, n
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_zlassq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
do j = 1, n - 1
call stdlib${ii}$_zlassq( n-j, a( j+1, j ), 1_${ik}$, scale, sum )
end do
end if
sum = 2_${ik}$*sum
do i = 1, n
if( real( a( i, i ),KIND=dp)/=zero ) then
absa = abs( real( a( i, i ),KIND=dp) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_zlanhe = value
return
end function stdlib${ii}$_zlanhe
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$lanhe( norm, uplo, n, a, lda, work )
!! ZLANHE: returns the value of the one norm, or the Frobenius norm, or
!! the infinity norm, or the element of largest absolute value of a
!! complex hermitian matrix A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm, uplo
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: absa, scale, sum, value
! Intrinsic Functions
! Executable Statements
if( n==0_${ik}$ ) then
value = zero
else if( stdlib_lsame( norm, 'M' ) ) then
! find max(abs(a(i,j))).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
do i = 1, j - 1
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
sum = abs( real( a( j, j ),KIND=${ck}$) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do j = 1, n
sum = abs( real( a( j, j ),KIND=${ck}$) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
do i = j + 1, n
sum = abs( a( i, j ) )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end do
end if
else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( &
norm=='1' ) ) then
! find normi(a) ( = norm1(a), since a is hermitian).
value = zero
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 1, n
sum = zero
do i = 1, j - 1
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
work( j ) = sum + abs( real( a( j, j ),KIND=${ck}$) )
end do
do i = 1, n
sum = work( i )
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
else
do i = 1, n
work( i ) = zero
end do
do j = 1, n
sum = work( j ) + abs( real( a( j, j ),KIND=${ck}$) )
do i = j + 1, n
absa = abs( a( i, j ) )
sum = sum + absa
work( i ) = work( i ) + absa
end do
if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum
end do
end if
else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) &
then
! find normf(a).
scale = zero
sum = one
if( stdlib_lsame( uplo, 'U' ) ) then
do j = 2, n
call stdlib${ii}$_${ci}$lassq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum )
end do
else
do j = 1, n - 1
call stdlib${ii}$_${ci}$lassq( n-j, a( j+1, j ), 1_${ik}$, scale, sum )
end do
end if
sum = 2_${ik}$*sum
do i = 1, n
if( real( a( i, i ),KIND=${ck}$)/=zero ) then
absa = abs( real( a( i, i ),KIND=${ck}$) )
if( scale<absa ) then
sum = one + sum*( scale / absa )**2_${ik}$
scale = absa
else
sum = sum + ( absa / scale )**2_${ik}$
end if
end if
end do
value = scale*sqrt( sum )
end if
stdlib${ii}$_${ci}$lanhe = value
return
end function stdlib${ii}$_${ci}$lanhe
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_blas_like_mnorm
