#:include "common.fypp" submodule(stdlib_lapack_solve) stdlib_lapack_solve_chol_comp implicit none contains #:for ik,it,ii in LINALG_INT_KINDS_TYPES pure module subroutine stdlib${ii}$_spocon( uplo, n, a, lda, anorm, rcond, work, iwork,info ) !! SPOCON estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric positive definite matrix using the !! Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(sp) :: ainvnm, scale, scalel, scaleu, smlnum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ else if( anorm<zero ) then info = -5_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPOCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of inv(a). kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**t). call stdlib${ii}$_slatrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, & scalel, work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_slatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scaleu, work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(l). call stdlib${ii}$_slatrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scalel, work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(l**t). call stdlib${ii}$_slatrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, & scaleu, work( 2_${ik}$*n+1 ), info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ ) if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_srscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_spocon pure module subroutine stdlib${ii}$_dpocon( uplo, n, a, lda, anorm, rcond, work, iwork,info ) !! DPOCON estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric positive definite matrix using the !! Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(dp) :: ainvnm, scale, scalel, scaleu, smlnum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ else if( anorm<zero ) then info = -5_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of inv(a). kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**t). call stdlib${ii}$_dlatrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, & scalel, work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_dlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scaleu, work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(l). call stdlib${ii}$_dlatrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scalel, work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(l**t). call stdlib${ii}$_dlatrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, & scaleu, work( 2_${ik}$*n+1 ), info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ ) if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_drscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_dpocon #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$pocon( uplo, n, a, lda, anorm, rcond, work, iwork,info ) !! DPOCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric positive definite matrix using the !! Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(${rk}$), intent(in) :: anorm real(${rk}$), intent(out) :: rcond ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(${rk}$) :: ainvnm, scale, scalel, scaleu, smlnum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ else if( anorm<zero ) then info = -5_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of inv(a). kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**t). call stdlib${ii}$_${ri}$latrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, & scalel, work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_${ri}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scaleu, work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(l). call stdlib${ii}$_${ri}$latrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scalel, work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(l**t). call stdlib${ii}$_${ri}$latrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, & scaleu, work( 2_${ik}$*n+1 ), info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ ) if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_${ri}$rscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_${ri}$pocon #:endif #:endfor pure module subroutine stdlib${ii}$_cpocon( uplo, n, a, lda, anorm, rcond, work, rwork,info ) !! CPOCON estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite matrix using the !! Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(sp) :: ainvnm, scale, scalel, scaleu, smlnum complex(sp) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(sp) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ else if( anorm<zero ) then info = -5_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPOCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of inv(a). kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**h). call stdlib${ii}$_clatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& work, scalel, rwork, info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_clatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scaleu, rwork, info ) else ! multiply by inv(l). call stdlib${ii}$_clatrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scalel, rwork, info ) normin = 'Y' ! multiply by inv(l**h). call stdlib${ii}$_clatrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& work, scaleu, rwork, info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ ) if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_csrscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_cpocon pure module subroutine stdlib${ii}$_zpocon( uplo, n, a, lda, anorm, rcond, work, rwork,info ) !! ZPOCON estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite matrix using the !! Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond ! Array Arguments real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(dp) :: ainvnm, scale, scalel, scaleu, smlnum complex(dp) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(dp) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ else if( anorm<zero ) then info = -5_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of inv(a). kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**h). call stdlib${ii}$_zlatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& work, scalel, rwork, info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_zlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scaleu, rwork, info ) else ! multiply by inv(l). call stdlib${ii}$_zlatrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scalel, rwork, info ) normin = 'Y' ! multiply by inv(l**h). call stdlib${ii}$_zlatrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& work, scaleu, rwork, info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ ) if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_zdrscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_zpocon #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$pocon( uplo, n, a, lda, anorm, rcond, work, rwork,info ) !! ZPOCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite matrix using the !! Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(${ck}$), intent(in) :: anorm real(${ck}$), intent(out) :: rcond ! Array Arguments real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(${ck}$) :: ainvnm, scale, scalel, scaleu, smlnum complex(${ck}$) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(${ck}$) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ else if( anorm<zero ) then info = -5_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of inv(a). kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**h). call stdlib${ii}$_${ci}$latrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& work, scalel, rwork, info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scaleu, rwork, info ) else ! multiply by inv(l). call stdlib${ii}$_${ci}$latrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scalel, rwork, info ) normin = 'Y' ! multiply by inv(l**h). call stdlib${ii}$_${ci}$latrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& work, scaleu, rwork, info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ ) if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_${ci}$drscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_${ci}$pocon #:endif #:endfor pure module subroutine stdlib${ii}$_spotrf( uplo, n, a, lda, info ) !! SPOTRF computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jb, nb ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPOTRF', -info ) return end if ! quick return if possible if( n==0 )return ! determine the block size for this environment. nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. call stdlib${ii}$_spotrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then ! compute the cholesky factorization a = u**t*u. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_ssyrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1_${ik}$, j ), lda, one, a(& j, j ), lda ) call stdlib${ii}$_spotrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( & 1_${ik}$, j ), lda, a( 1_${ik}$, j+jb ),lda, one, a( j, j+jb ), lda ) call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, & one, a( j, j ), lda,a( j, j+jb ), lda ) end if end do else ! compute the cholesky factorization a = l*l**t. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_ssyrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) call stdlib${ii}$_spotrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( & j+jb, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda, one, a( j+jb, j ), lda ) call stdlib${ii}$_strsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, & one, a( j, j ), lda,a( j+jb, j ), lda ) end if end do end if end if go to 40 30 continue info = info + j - 1_${ik}$ 40 continue return end subroutine stdlib${ii}$_spotrf pure module subroutine stdlib${ii}$_dpotrf( uplo, n, a, lda, info ) !! DPOTRF computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jb, nb ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOTRF', -info ) return end if ! quick return if possible if( n==0 )return ! determine the block size for this environment. nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. call stdlib${ii}$_dpotrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then ! compute the cholesky factorization a = u**t*u. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_dsyrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1_${ik}$, j ), lda, one, a(& j, j ), lda ) call stdlib${ii}$_dpotrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. call stdlib${ii}$_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( & 1_${ik}$, j ), lda, a( 1_${ik}$, j+jb ),lda, one, a( j, j+jb ), lda ) call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, & one, a( j, j ), lda,a( j, j+jb ), lda ) end if end do else ! compute the cholesky factorization a = l*l**t. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_dsyrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) call stdlib${ii}$_dpotrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( & j+jb, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda, one, a( j+jb, j ), lda ) call stdlib${ii}$_dtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, & one, a( j, j ), lda,a( j+jb, j ), lda ) end if end do end if end if go to 40 30 continue info = info + j - 1_${ik}$ 40 continue return end subroutine stdlib${ii}$_dpotrf #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$potrf( uplo, n, a, lda, info ) !! DPOTRF: computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jb, nb ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOTRF', -info ) return end if ! quick return if possible if( n==0 )return ! determine the block size for this environment. nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. call stdlib${ii}$_${ri}$potrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then ! compute the cholesky factorization a = u**t*u. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_${ri}$syrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1_${ik}$, j ), lda, one, a(& j, j ), lda ) call stdlib${ii}$_${ri}$potrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( & 1_${ik}$, j ), lda, a( 1_${ik}$, j+jb ),lda, one, a( j, j+jb ), lda ) call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, & one, a( j, j ), lda,a( j, j+jb ), lda ) end if end do else ! compute the cholesky factorization a = l*l**t. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_${ri}$syrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) call stdlib${ii}$_${ri}$potrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( & j+jb, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda, one, a( j+jb, j ), lda ) call stdlib${ii}$_${ri}$trsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, & one, a( j, j ), lda,a( j+jb, j ), lda ) end if end do end if end if go to 40 30 continue info = info + j - 1_${ik}$ 40 continue return end subroutine stdlib${ii}$_${ri}$potrf #:endif #:endfor pure module subroutine stdlib${ii}$_cpotrf( uplo, n, a, lda, info ) !! CPOTRF computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jb, nb ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPOTRF', -info ) return end if ! quick return if possible if( n==0 )return ! determine the block size for this environment. nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. call stdlib${ii}$_cpotrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then ! compute the cholesky factorization a = u**h *u. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_cherk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1_${ik}$, j ), & lda, one, a( j, j ), lda ) call stdlib${ii}$_cpotrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& -cone, a( 1_${ik}$, j ), lda,a( 1_${ik}$, j+jb ), lda, cone, a( j, j+jb ),lda ) call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & n-j-jb+1, cone, a( j, j ),lda, a( j, j+jb ), lda ) end if end do else ! compute the cholesky factorization a = l*l**h. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_cherk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) call stdlib${ii}$_cpotrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& -cone, a( j+jb, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), lda, cone, a( j+jb, j ),lda ) call stdlib${ii}$_ctrsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& jb+1, jb, cone, a( j, j ),lda, a( j+jb, j ), lda ) end if end do end if end if go to 40 30 continue info = info + j - 1_${ik}$ 40 continue return end subroutine stdlib${ii}$_cpotrf pure module subroutine stdlib${ii}$_zpotrf( uplo, n, a, lda, info ) !! ZPOTRF computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jb, nb ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOTRF', -info ) return end if ! quick return if possible if( n==0 )return ! determine the block size for this environment. nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. call stdlib${ii}$_zpotrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then ! compute the cholesky factorization a = u**h *u. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_zherk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1_${ik}$, j ), & lda, one, a( j, j ), lda ) call stdlib${ii}$_zpotrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& -cone, a( 1_${ik}$, j ), lda,a( 1_${ik}$, j+jb ), lda, cone, a( j, j+jb ),lda ) call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & n-j-jb+1, cone, a( j, j ),lda, a( j, j+jb ), lda ) end if end do else ! compute the cholesky factorization a = l*l**h. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_zherk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) call stdlib${ii}$_zpotrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& -cone, a( j+jb, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), lda, cone, a( j+jb, j ),lda ) call stdlib${ii}$_ztrsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& jb+1, jb, cone, a( j, j ),lda, a( j+jb, j ), lda ) end if end do end if end if go to 40 30 continue info = info + j - 1_${ik}$ 40 continue return end subroutine stdlib${ii}$_zpotrf #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$potrf( uplo, n, a, lda, info ) !! ZPOTRF: computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jb, nb ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOTRF', -info ) return end if ! quick return if possible if( n==0 )return ! determine the block size for this environment. nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. call stdlib${ii}$_${ci}$potrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then ! compute the cholesky factorization a = u**h *u. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1_${ik}$, j ), & lda, one, a( j, j ), lda ) call stdlib${ii}$_${ci}$potrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& -cone, a( 1_${ik}$, j ), lda,a( 1_${ik}$, j+jb ), lda, cone, a( j, j+jb ),lda ) call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & n-j-jb+1, cone, a( j, j ),lda, a( j, j+jb ), lda ) end if end do else ! compute the cholesky factorization a = l*l**h. do j = 1, n, nb ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) call stdlib${ii}$_${ci}$herk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) call stdlib${ii}$_${ci}$potrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& -cone, a( j+jb, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), lda, cone, a( j+jb, j ),lda ) call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& jb+1, jb, cone, a( j, j ),lda, a( j+jb, j ), lda ) end if end do end if end if go to 40 30 continue info = info + j - 1_${ik}$ 40 continue return end subroutine stdlib${ii}$_${ci}$potrf #:endif #:endfor pure recursive module subroutine stdlib${ii}$_spotrf2( uplo, n, a, lda, info ) !! SPOTRF2 computes the Cholesky factorization of a real symmetric !! positive definite matrix A using the recursive algorithm. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the recursive version of the algorithm. It divides !! the matrix into four submatrices: !! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 !! A = [ -----|----- ] with n1 = n/2 !! [ A21 | A22 ] n2 = n-n1 !! The subroutine calls itself to factor A11. Update and scale A21 !! or A12, update A22 then call itself to factor A22. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: n1, n2, iinfo ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPOTRF2', -info ) return end if ! quick return if possible if( n==0 )return ! n=1 case if( n==1_${ik}$ ) then ! test for non-positive-definiteness if( a( 1_${ik}$, 1_${ik}$ )<=zero.or.stdlib${ii}$_sisnan( a( 1_${ik}$, 1_${ik}$ ) ) ) then info = 1_${ik}$ return end if ! factor a( 1_${ik}$, 1_${ik}$ ) = sqrt( a( 1_${ik}$, 1_${ik}$ ) ) ! use recursive code else n1 = n/2_${ik}$ n2 = n-n1 ! factor a11 call stdlib${ii}$_spotrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo return end if ! compute the cholesky factorization a = u**t*u if( upper ) then ! update and scale a12 call stdlib${ii}$_strsm( 'L', 'U', 'T', 'N', n1, n2, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ), & lda ) ! update and factor a22 call stdlib${ii}$_ssyrk( uplo, 'T', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_spotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if ! compute the cholesky factorization a = l*l**t else ! update and scale a21 call stdlib${ii}$_strsm( 'R', 'L', 'T', 'N', n2, n1, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ), & lda ) ! update and factor a22 call stdlib${ii}$_ssyrk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_spotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if end if end if return end subroutine stdlib${ii}$_spotrf2 pure recursive module subroutine stdlib${ii}$_dpotrf2( uplo, n, a, lda, info ) !! DPOTRF2 computes the Cholesky factorization of a real symmetric !! positive definite matrix A using the recursive algorithm. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the recursive version of the algorithm. It divides !! the matrix into four submatrices: !! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 !! A = [ -----|----- ] with n1 = n/2 !! [ A21 | A22 ] n2 = n-n1 !! The subroutine calls itself to factor A11. Update and scale A21 !! or A12, update A22 then calls itself to factor A22. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: n1, n2, iinfo ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOTRF2', -info ) return end if ! quick return if possible if( n==0 )return ! n=1 case if( n==1_${ik}$ ) then ! test for non-positive-definiteness if( a( 1_${ik}$, 1_${ik}$ )<=zero.or.stdlib${ii}$_disnan( a( 1_${ik}$, 1_${ik}$ ) ) ) then info = 1_${ik}$ return end if ! factor a( 1_${ik}$, 1_${ik}$ ) = sqrt( a( 1_${ik}$, 1_${ik}$ ) ) ! use recursive code else n1 = n/2_${ik}$ n2 = n-n1 ! factor a11 call stdlib${ii}$_dpotrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo return end if ! compute the cholesky factorization a = u**t*u if( upper ) then ! update and scale a12 call stdlib${ii}$_dtrsm( 'L', 'U', 'T', 'N', n1, n2, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ), & lda ) ! update and factor a22 call stdlib${ii}$_dsyrk( uplo, 'T', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_dpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if ! compute the cholesky factorization a = l*l**t else ! update and scale a21 call stdlib${ii}$_dtrsm( 'R', 'L', 'T', 'N', n2, n1, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ), & lda ) ! update and factor a22 call stdlib${ii}$_dsyrk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_dpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if end if end if return end subroutine stdlib${ii}$_dpotrf2 #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure recursive module subroutine stdlib${ii}$_${ri}$potrf2( uplo, n, a, lda, info ) !! DPOTRF2: computes the Cholesky factorization of a real symmetric !! positive definite matrix A using the recursive algorithm. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the recursive version of the algorithm. It divides !! the matrix into four submatrices: !! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 !! A = [ -----|----- ] with n1 = n/2 !! [ A21 | A22 ] n2 = n-n1 !! The subroutine calls itself to factor A11. Update and scale A21 !! or A12, update A22 then calls itself to factor A22. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: n1, n2, iinfo ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOTRF2', -info ) return end if ! quick return if possible if( n==0 )return ! n=1 case if( n==1_${ik}$ ) then ! test for non-positive-definiteness if( a( 1_${ik}$, 1_${ik}$ )<=zero.or.stdlib${ii}$_${ri}$isnan( a( 1_${ik}$, 1_${ik}$ ) ) ) then info = 1_${ik}$ return end if ! factor a( 1_${ik}$, 1_${ik}$ ) = sqrt( a( 1_${ik}$, 1_${ik}$ ) ) ! use recursive code else n1 = n/2_${ik}$ n2 = n-n1 ! factor a11 call stdlib${ii}$_${ri}$potrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo return end if ! compute the cholesky factorization a = u**t*u if( upper ) then ! update and scale a12 call stdlib${ii}$_${ri}$trsm( 'L', 'U', 'T', 'N', n1, n2, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ), & lda ) ! update and factor a22 call stdlib${ii}$_${ri}$syrk( uplo, 'T', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_${ri}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if ! compute the cholesky factorization a = l*l**t else ! update and scale a21 call stdlib${ii}$_${ri}$trsm( 'R', 'L', 'T', 'N', n2, n1, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ), & lda ) ! update and factor a22 call stdlib${ii}$_${ri}$syrk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_${ri}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if end if end if return end subroutine stdlib${ii}$_${ri}$potrf2 #:endif #:endfor pure recursive module subroutine stdlib${ii}$_cpotrf2( uplo, n, a, lda, info ) !! CPOTRF2 computes the Cholesky factorization of a Hermitian !! positive definite matrix A using the recursive algorithm. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the recursive version of the algorithm. It divides !! the matrix into four submatrices: !! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 !! A = [ -----|----- ] with n1 = n/2 !! [ A21 | A22 ] n2 = n-n1 !! The subroutine calls itself to factor A11. Update and scale A21 !! or A12, update A22 then calls itself to factor A22. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: n1, n2, iinfo real(sp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPOTRF2', -info ) return end if ! quick return if possible if( n==0 )return ! n=1 case if( n==1_${ik}$ ) then ! test for non-positive-definiteness ajj = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then info = 1_${ik}$ return end if ! factor a( 1_${ik}$, 1_${ik}$ ) = sqrt( ajj ) ! use recursive code else n1 = n/2_${ik}$ n2 = n-n1 ! factor a11 call stdlib${ii}$_cpotrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo return end if ! compute the cholesky factorization a = u**h*u if( upper ) then ! update and scale a12 call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'N', n1, n2, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ),& lda ) ! update and factor a22 call stdlib${ii}$_cherk( uplo, 'C', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_cpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if ! compute the cholesky factorization a = l*l**h else ! update and scale a21 call stdlib${ii}$_ctrsm( 'R', 'L', 'C', 'N', n2, n1, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ),& lda ) ! update and factor a22 call stdlib${ii}$_cherk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_cpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if end if end if return end subroutine stdlib${ii}$_cpotrf2 pure recursive module subroutine stdlib${ii}$_zpotrf2( uplo, n, a, lda, info ) !! ZPOTRF2 computes the Cholesky factorization of a Hermitian !! positive definite matrix A using the recursive algorithm. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the recursive version of the algorithm. It divides !! the matrix into four submatrices: !! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 !! A = [ -----|----- ] with n1 = n/2 !! [ A21 | A22 ] n2 = n-n1 !! The subroutine calls itself to factor A11. Update and scale A21 !! or A12, update A22 then call itself to factor A22. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: n1, n2, iinfo real(dp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOTRF2', -info ) return end if ! quick return if possible if( n==0 )return ! n=1 case if( n==1_${ik}$ ) then ! test for non-positive-definiteness ajj = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then info = 1_${ik}$ return end if ! factor a( 1_${ik}$, 1_${ik}$ ) = sqrt( ajj ) ! use recursive code else n1 = n/2_${ik}$ n2 = n-n1 ! factor a11 call stdlib${ii}$_zpotrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo return end if ! compute the cholesky factorization a = u**h*u if( upper ) then ! update and scale a12 call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'N', n1, n2, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ),& lda ) ! update and factor a22 call stdlib${ii}$_zherk( uplo, 'C', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_zpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if ! compute the cholesky factorization a = l*l**h else ! update and scale a21 call stdlib${ii}$_ztrsm( 'R', 'L', 'C', 'N', n2, n1, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ),& lda ) ! update and factor a22 call stdlib${ii}$_zherk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_zpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if end if end if return end subroutine stdlib${ii}$_zpotrf2 #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure recursive module subroutine stdlib${ii}$_${ci}$potrf2( uplo, n, a, lda, info ) !! ZPOTRF2: computes the Cholesky factorization of a Hermitian !! positive definite matrix A using the recursive algorithm. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the recursive version of the algorithm. It divides !! the matrix into four submatrices: !! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 !! A = [ -----|----- ] with n1 = n/2 !! [ A21 | A22 ] n2 = n-n1 !! The subroutine calls itself to factor A11. Update and scale A21 !! or A12, update A22 then call itself to factor A22. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: n1, n2, iinfo real(${ck}$) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOTRF2', -info ) return end if ! quick return if possible if( n==0 )return ! n=1 case if( n==1_${ik}$ ) then ! test for non-positive-definiteness ajj = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then info = 1_${ik}$ return end if ! factor a( 1_${ik}$, 1_${ik}$ ) = sqrt( ajj ) ! use recursive code else n1 = n/2_${ik}$ n2 = n-n1 ! factor a11 call stdlib${ii}$_${ci}$potrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo return end if ! compute the cholesky factorization a = u**h*u if( upper ) then ! update and scale a12 call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'N', n1, n2, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ),& lda ) ! update and factor a22 call stdlib${ii}$_${ci}$herk( uplo, 'C', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_${ci}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if ! compute the cholesky factorization a = l*l**h else ! update and scale a21 call stdlib${ii}$_${ci}$trsm( 'R', 'L', 'C', 'N', n2, n1, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ),& lda ) ! update and factor a22 call stdlib${ii}$_${ci}$herk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 & ), lda ) call stdlib${ii}$_${ci}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0_${ik}$ ) then info = iinfo + n1 return end if end if end if return end subroutine stdlib${ii}$_${ci}$potrf2 #:endif #:endfor pure module subroutine stdlib${ii}$_spotf2( uplo, n, a, lda, info ) !! SPOTF2 computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form !! A = U**T * U , if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the unblocked version of the algorithm, calling Level 2 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j real(sp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPOTF2', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**t *u. do j = 1, n ! compute u(j,j) and test for non-positive-definiteness. ajj = a( j, j ) - stdlib${ii}$_sdot( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ ) if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_sgemv( 'TRANSPOSE', j-1, n-j, -one, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), 1_${ik}$,& one, a( j, j+1 ), lda ) call stdlib${ii}$_sscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do else ! compute the cholesky factorization a = l*l**t. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = a( j, j ) - stdlib${ii}$_sdot( j-1, a( j, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda ) if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-j, j-1, -one, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ),& lda, one, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_sscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_spotf2 pure module subroutine stdlib${ii}$_dpotf2( uplo, n, a, lda, info ) !! DPOTF2 computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form !! A = U**T * U , if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the unblocked version of the algorithm, calling Level 2 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j real(dp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOTF2', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**t *u. do j = 1, n ! compute u(j,j) and test for non-positive-definiteness. ajj = a( j, j ) - stdlib${ii}$_ddot( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ ) if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_dgemv( 'TRANSPOSE', j-1, n-j, -one, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), 1_${ik}$,& one, a( j, j+1 ), lda ) call stdlib${ii}$_dscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do else ! compute the cholesky factorization a = l*l**t. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = a( j, j ) - stdlib${ii}$_ddot( j-1, a( j, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda ) if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-j, j-1, -one, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ),& lda, one, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_dpotf2 #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$potf2( uplo, n, a, lda, info ) !! DPOTF2: computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form !! A = U**T * U , if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the unblocked version of the algorithm, calling Level 2 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j real(${rk}$) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOTF2', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**t *u. do j = 1, n ! compute u(j,j) and test for non-positive-definiteness. ajj = a( j, j ) - stdlib${ii}$_${ri}$dot( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ ) if( ajj<=zero.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', j-1, n-j, -one, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), 1_${ik}$,& one, a( j, j+1 ), lda ) call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do else ! compute the cholesky factorization a = l*l**t. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = a( j, j ) - stdlib${ii}$_${ri}$dot( j-1, a( j, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda ) if( ajj<=zero.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-j, j-1, -one, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ),& lda, one, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_${ri}$potf2 #:endif #:endfor pure module subroutine stdlib${ii}$_cpotf2( uplo, n, a, lda, info ) !! CPOTF2 computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form !! A = U**H * U , if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the unblocked version of the algorithm, calling Level 2 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j real(sp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPOTF2', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**h *u. do j = 1, n ! compute u(j,j) and test for non-positive-definiteness. ajj = real( real( a( j, j ),KIND=sp) - stdlib${ii}$_cdotc( j-1, a( 1_${ik}$, j ), 1_${ik}$,a( 1_${ik}$, j ),& 1_${ik}$ ),KIND=sp) if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_cgemv( 'TRANSPOSE', j-1, n-j, -cone, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), & 1_${ik}$, cone, a( j, j+1 ), lda ) call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_csscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do else ! compute the cholesky factorization a = l*l**h. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = real( real( a( j, j ),KIND=sp) - stdlib${ii}$_cdotc( j-1, a( j, 1_${ik}$ ), lda,a( j, 1_${ik}$ & ), lda ),KIND=sp) if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ )& , lda, cone, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_csscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_cpotf2 pure module subroutine stdlib${ii}$_zpotf2( uplo, n, a, lda, info ) !! ZPOTF2 computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form !! A = U**H * U , if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the unblocked version of the algorithm, calling Level 2 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j real(dp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOTF2', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**h *u. do j = 1, n ! compute u(j,j) and test for non-positive-definiteness. ajj = real( a( j, j ),KIND=dp) - real( stdlib${ii}$_zdotc( j-1, a( 1_${ik}$, j ), 1_${ik}$,a( 1_${ik}$, j ),& 1_${ik}$ ),KIND=dp) if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_zgemv( 'TRANSPOSE', j-1, n-j, -cone, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), & 1_${ik}$, cone, a( j, j+1 ), lda ) call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_zdscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do else ! compute the cholesky factorization a = l*l**h. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = real( a( j, j ),KIND=dp) - real( stdlib${ii}$_zdotc( j-1, a( j, 1_${ik}$ ), lda,a( j, 1_${ik}$ & ), lda ),KIND=dp) if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ )& , lda, cone, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_zdscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_zpotf2 #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$potf2( uplo, n, a, lda, info ) !! ZPOTF2: computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form !! A = U**H * U , if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the unblocked version of the algorithm, calling Level 2 BLAS. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j real(${ck}$) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOTF2', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**h *u. do j = 1, n ! compute u(j,j) and test for non-positive-definiteness. ajj = real( a( j, j ),KIND=${ck}$) - real( stdlib${ii}$_${ci}$dotc( j-1, a( 1_${ik}$, j ), 1_${ik}$,a( 1_${ik}$, j ),& 1_${ik}$ ),KIND=${ck}$) if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', j-1, n-j, -cone, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), & 1_${ik}$, cone, a( j, j+1 ), lda ) call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do else ! compute the cholesky factorization a = l*l**h. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = real( a( j, j ),KIND=${ck}$) - real( stdlib${ii}$_${ci}$dotc( j-1, a( j, 1_${ik}$ ), lda,a( j, 1_${ik}$ & ), lda ),KIND=${ck}$) if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 30 end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ )& , lda, cone, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_${ci}$potf2 #:endif #:endfor pure module subroutine stdlib${ii}$_spstrf( uplo, n, a, lda, piv, rank, tol, work, info ) !! SPSTRF computes the Cholesky factorization with complete !! pivoting of a real symmetric positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**T * U , if UPLO = 'U', !! P**T * A * P = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 3 BLAS. ! -- 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 real(sp), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars real(sp) :: ajj, sstop, stemp integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPSTRF', -info ) return end if ! quick return if possible if( n==0 )return ! get block size nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code call stdlib${ii}$_spstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info ) go to 200 else ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value pvt = 1_${ik}$ ajj = a( pvt, pvt ) do i = 2, n if( a( i, i )>ajj ) then pvt = i ajj = a( pvt, pvt ) end if end do if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 200 end if ! compute stopping value if not supplied if( tol<zero ) then sstop = n * stdlib${ii}$_slamch( 'EPSILON' ) * ajj else sstop = tol end if if( upper ) then ! compute the cholesky factorization p**t * a * p = u**t * u loop_140: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first half of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_130: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>k ) then work( i ) = work( i ) + a( j-1, i )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_sswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_sswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),& lda ) call stdlib${ii}$_sswap( pvt-j-1, a( j, j+1 ), lda,a( j+1, pvt ), 1_${ik}$ ) ! swap dot products and piv stemp = work( j ) work( j ) = work( pvt ) work( pvt ) = stemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_sgemv( 'TRANS', j-k, n-j, -one, a( k, j+1 ),lda, a( k, j ), & 1_${ik}$, one, a( j, j+1 ),lda ) call stdlib${ii}$_sscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_130 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_ssyrk( 'UPPER', 'TRANS', n-j+1, jb, -one,a( k, j ), lda, one, & a( j, j ), lda ) end if end do loop_140 else ! compute the cholesky factorization p**t * a * p = l * l**t loop_180: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first half of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_170: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>k ) then work( i ) = work( i ) + a( i, j-1 )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_sswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_sswap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), & 1_${ik}$ ) call stdlib${ii}$_sswap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ),lda ) ! swap dot products and piv stemp = work( j ) work( j ) = work( pvt ) work( pvt ) = stemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_sgemv( 'NO TRANS', n-j, j-k, -one,a( j+1, k ), lda, a( j, k & ), lda, one,a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_sscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_170 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_ssyrk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, & one, a( j, j ), lda ) end if end do loop_180 end if end if ! ran to completion, a has full rank rank = n go to 200 190 continue ! rank is the number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 200 continue return end subroutine stdlib${ii}$_spstrf pure module subroutine stdlib${ii}$_dpstrf( uplo, n, a, lda, piv, rank, tol, work, info ) !! DPSTRF computes the Cholesky factorization with complete !! pivoting of a real symmetric positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**T * U , if UPLO = 'U', !! P**T * A * P = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 3 BLAS. ! -- 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 real(dp), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars real(dp) :: ajj, dstop, dtemp integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPSTRF', -info ) return end if ! quick return if possible if( n==0 )return ! get block size nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code call stdlib${ii}$_dpstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info ) go to 200 else ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value pvt = 1_${ik}$ ajj = a( pvt, pvt ) do i = 2, n if( a( i, i )>ajj ) then pvt = i ajj = a( pvt, pvt ) end if end do if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 200 end if ! compute stopping value if not supplied if( tol<zero ) then dstop = n * stdlib${ii}$_dlamch( 'EPSILON' ) * ajj else dstop = tol end if if( upper ) then ! compute the cholesky factorization p**t * a * p = u**t * u loop_140: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first half of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_130: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>k ) then work( i ) = work( i ) + a( j-1, i )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_dswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_dswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),& lda ) call stdlib${ii}$_dswap( pvt-j-1, a( j, j+1 ), lda,a( j+1, pvt ), 1_${ik}$ ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_dgemv( 'TRANS', j-k, n-j, -one, a( k, j+1 ),lda, a( k, j ), & 1_${ik}$, one, a( j, j+1 ),lda ) call stdlib${ii}$_dscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_130 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_dsyrk( 'UPPER', 'TRANS', n-j+1, jb, -one,a( k, j ), lda, one, & a( j, j ), lda ) end if end do loop_140 else ! compute the cholesky factorization p**t * a * p = l * l**t loop_180: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first half of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_170: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>k ) then work( i ) = work( i ) + a( i, j-1 )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_dswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_dswap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), & 1_${ik}$ ) call stdlib${ii}$_dswap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ),lda ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_dgemv( 'NO TRANS', n-j, j-k, -one,a( j+1, k ), lda, a( j, k & ), lda, one,a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_170 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_dsyrk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, & one, a( j, j ), lda ) end if end do loop_180 end if end if ! ran to completion, a has full rank rank = n go to 200 190 continue ! rank is the number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 200 continue return end subroutine stdlib${ii}$_dpstrf #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$pstrf( uplo, n, a, lda, piv, rank, tol, work, info ) !! DPSTRF: computes the Cholesky factorization with complete !! pivoting of a real symmetric positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**T * U , if UPLO = 'U', !! P**T * A * P = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 3 BLAS. ! -- 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 real(${rk}$), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars real(${rk}$) :: ajj, dstop, dtemp integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPSTRF', -info ) return end if ! quick return if possible if( n==0 )return ! get block size nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code call stdlib${ii}$_${ri}$pstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info ) go to 200 else ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value pvt = 1_${ik}$ ajj = a( pvt, pvt ) do i = 2, n if( a( i, i )>ajj ) then pvt = i ajj = a( pvt, pvt ) end if end do if( ajj<=zero.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 200 end if ! compute stopping value if not supplied if( tol<zero ) then dstop = n * stdlib${ii}$_${ri}$lamch( 'EPSILON' ) * ajj else dstop = tol end if if( upper ) then ! compute the cholesky factorization p**t * a * p = u**t * u loop_140: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first half of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_130: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>k ) then work( i ) = work( i ) + a( j-1, i )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_${ri}$swap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_${ri}$swap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),& lda ) call stdlib${ii}$_${ri}$swap( pvt-j-1, a( j, j+1 ), lda,a( j+1, pvt ), 1_${ik}$ ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_${ri}$gemv( 'TRANS', j-k, n-j, -one, a( k, j+1 ),lda, a( k, j ), & 1_${ik}$, one, a( j, j+1 ),lda ) call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_130 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_${ri}$syrk( 'UPPER', 'TRANS', n-j+1, jb, -one,a( k, j ), lda, one, & a( j, j ), lda ) end if end do loop_140 else ! compute the cholesky factorization p**t * a * p = l * l**t loop_180: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first half of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_170: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>k ) then work( i ) = work( i ) + a( i, j-1 )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_${ri}$swap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_${ri}$swap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), & 1_${ik}$ ) call stdlib${ii}$_${ri}$swap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ),lda ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_${ri}$gemv( 'NO TRANS', n-j, j-k, -one,a( j+1, k ), lda, a( j, k & ), lda, one,a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_170 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_${ri}$syrk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, & one, a( j, j ), lda ) end if end do loop_180 end if end if ! ran to completion, a has full rank rank = n go to 200 190 continue ! rank is the number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 200 continue return end subroutine stdlib${ii}$_${ri}$pstrf #:endif #:endfor pure module subroutine stdlib${ii}$_cpstrf( uplo, n, a, lda, piv, rank, tol, work, info ) !! CPSTRF computes the Cholesky factorization with complete !! pivoting of a complex Hermitian positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**H * U , if UPLO = 'U', !! P**T * A * P = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 3 BLAS. ! -- 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 real(sp), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments complex(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars complex(sp) :: ctemp real(sp) :: ajj, sstop, stemp integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPSTRF', -info ) return end if ! quick return if possible if( n==0 )return ! get block size nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code call stdlib${ii}$_cpstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info ) go to 230 else ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value do i = 1, n work( i ) = real( a( i, i ),KIND=sp) end do pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ ) ajj = real( a( pvt, pvt ),KIND=sp) if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 230 end if ! compute stopping value if not supplied if( tol<zero ) then sstop = n * stdlib${ii}$_slamch( 'EPSILON' ) * ajj else sstop = tol end if if( upper ) then ! compute the cholesky factorization p**t * a * p = u**h * u loop_160: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first chalf of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_150: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>k ) then work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),& KIND=sp) end if work( n+i ) = real( a( i, i ),KIND=sp) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 220 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_cswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_cswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),& lda ) do i = j + 1, pvt - 1 ctemp = conjg( a( j, i ) ) a( j, i ) = conjg( a( i, pvt ) ) a( i, pvt ) = ctemp end do a( j, pvt ) = conjg( a( j, pvt ) ) ! swap dot products and piv stemp = work( j ) work( j ) = work( pvt ) work( pvt ) = stemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_cgemv( 'TRANS', j-k, n-j, -cone, a( k, j+1 ),lda, a( k, j ),& 1_${ik}$, cone, a( j, j+1 ),lda ) call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_csscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_150 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_cherk( 'UPPER', 'CONJ TRANS', n-j+1, jb, -one,a( k, j ), lda, & one, a( j, j ), lda ) end if end do loop_160 else ! compute the cholesky factorization p**t * a * p = l * l**h loop_210: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first chalf of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_200: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>k ) then work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),& KIND=sp) end if work( n+i ) = real( a( i, i ),KIND=sp) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 220 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_cswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_cswap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), & 1_${ik}$ ) do i = j + 1, pvt - 1 ctemp = conjg( a( i, j ) ) a( i, j ) = conjg( a( pvt, i ) ) a( pvt, i ) = ctemp end do a( pvt, j ) = conjg( a( pvt, j ) ) ! swap dot products and piv stemp = work( j ) work( j ) = work( pvt ) work( pvt ) = stemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_cgemv( 'NO TRANS', n-j, j-k, -cone,a( j+1, k ), lda, a( j, & k ), lda, cone,a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_csscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_200 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_cherk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, & one, a( j, j ), lda ) end if end do loop_210 end if end if ! ran to completion, a has full rank rank = n go to 230 220 continue ! rank is the number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 230 continue return end subroutine stdlib${ii}$_cpstrf pure module subroutine stdlib${ii}$_zpstrf( uplo, n, a, lda, piv, rank, tol, work, info ) !! ZPSTRF computes the Cholesky factorization with complete !! pivoting of a complex Hermitian positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**H * U , if UPLO = 'U', !! P**T * A * P = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 3 BLAS. ! -- 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 real(dp), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments complex(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars complex(dp) :: ztemp real(dp) :: ajj, dstop, dtemp integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPSTRF', -info ) return end if ! quick return if possible if( n==0 )return ! get block size nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code call stdlib${ii}$_zpstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info ) go to 230 else ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value do i = 1, n work( i ) = real( a( i, i ),KIND=dp) end do pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ ) ajj = real( a( pvt, pvt ),KIND=dp) if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 230 end if ! compute stopping value if not supplied if( tol<zero ) then dstop = n * stdlib${ii}$_dlamch( 'EPSILON' ) * ajj else dstop = tol end if if( upper ) then ! compute the cholesky factorization p**t * a * p = u**h * u loop_160: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first chalf of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_150: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>k ) then work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),& KIND=dp) end if work( n+i ) = real( a( i, i ),KIND=dp) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 220 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_zswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_zswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),& lda ) do i = j + 1, pvt - 1 ztemp = conjg( a( j, i ) ) a( j, i ) = conjg( a( i, pvt ) ) a( i, pvt ) = ztemp end do a( j, pvt ) = conjg( a( j, pvt ) ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_zgemv( 'TRANS', j-k, n-j, -cone, a( k, j+1 ),lda, a( k, j ),& 1_${ik}$, cone, a( j, j+1 ),lda ) call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_zdscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_150 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_zherk( 'UPPER', 'CONJ TRANS', n-j+1, jb, -one,a( k, j ), lda, & one, a( j, j ), lda ) end if end do loop_160 else ! compute the cholesky factorization p**t * a * p = l * l**h loop_210: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first chalf of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_200: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>k ) then work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),& KIND=dp) end if work( n+i ) = real( a( i, i ),KIND=dp) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 220 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_zswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_zswap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), & 1_${ik}$ ) do i = j + 1, pvt - 1 ztemp = conjg( a( i, j ) ) a( i, j ) = conjg( a( pvt, i ) ) a( pvt, i ) = ztemp end do a( pvt, j ) = conjg( a( pvt, j ) ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_zgemv( 'NO TRANS', n-j, j-k, -cone,a( j+1, k ), lda, a( j, & k ), lda, cone,a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_zdscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_200 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_zherk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, & one, a( j, j ), lda ) end if end do loop_210 end if end if ! ran to completion, a has full rank rank = n go to 230 220 continue ! rank is the number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 230 continue return end subroutine stdlib${ii}$_zpstrf #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$pstrf( uplo, n, a, lda, piv, rank, tol, work, info ) !! ZPSTRF: computes the Cholesky factorization with complete !! pivoting of a complex Hermitian positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**H * U , if UPLO = 'U', !! P**T * A * P = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 3 BLAS. ! -- 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 real(${ck}$), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) real(${ck}$), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars complex(${ck}$) :: ztemp real(${ck}$) :: ajj, dstop, dtemp integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPSTRF', -info ) return end if ! quick return if possible if( n==0 )return ! get block size nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code call stdlib${ii}$_${ci}$pstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info ) go to 230 else ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value do i = 1, n work( i ) = real( a( i, i ),KIND=${ck}$) end do pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ ) ajj = real( a( pvt, pvt ),KIND=${ck}$) if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 230 end if ! compute stopping value if not supplied if( tol<zero ) then dstop = n * stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) * ajj else dstop = tol end if if( upper ) then ! compute the cholesky factorization p**t * a * p = u**h * u loop_160: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first chalf of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_150: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>k ) then work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),& KIND=${ck}$) end if work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 220 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_${ci}$swap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_${ci}$swap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),& lda ) do i = j + 1, pvt - 1 ztemp = conjg( a( j, i ) ) a( j, i ) = conjg( a( i, pvt ) ) a( i, pvt ) = ztemp end do a( j, pvt ) = conjg( a( j, pvt ) ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j. if( j<n ) then call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_${ci}$gemv( 'TRANS', j-k, n-j, -cone, a( k, j+1 ),lda, a( k, j ),& 1_${ik}$, cone, a( j, j+1 ),lda ) call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_150 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_${ci}$herk( 'UPPER', 'CONJ TRANS', n-j+1, jb, -one,a( k, j ), lda, & one, a( j, j ), lda ) end if end do loop_160 else ! compute the cholesky factorization p**t * a * p = l * l**h loop_210: do k = 1, n, nb ! account for last block not being nb wide jb = min( nb, n-k+1 ) ! set relevant part of first chalf of work to zero, ! holds dot products do i = k, n work( i ) = 0_${ik}$ end do loop_200: do j = k, k + jb - 1 ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>k ) then work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),& KIND=${ck}$) end if work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 220 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_${ci}$swap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_${ci}$swap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), & 1_${ik}$ ) do i = j + 1, pvt - 1 ztemp = conjg( a( i, j ) ) a( i, j ) = conjg( a( pvt, i ) ) a( pvt, i ) = ztemp end do a( pvt, j ) = conjg( a( pvt, j ) ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j. if( j<n ) then call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_${ci}$gemv( 'NO TRANS', n-j, j-k, -cone,a( j+1, k ), lda, a( j, & k ), lda, cone,a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_200 ! update trailing matrix, j already incremented if( k+jb<=n ) then call stdlib${ii}$_${ci}$herk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, & one, a( j, j ), lda ) end if end do loop_210 end if end if ! ran to completion, a has full rank rank = n go to 230 220 continue ! rank is the number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 230 continue return end subroutine stdlib${ii}$_${ci}$pstrf #:endif #:endfor pure module subroutine stdlib${ii}$_spstf2( uplo, n, a, lda, piv, rank, tol, work, info ) !! SPSTF2 computes the Cholesky factorization with complete !! pivoting of a real symmetric positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**T * U , if UPLO = 'U', !! P**T * A * P = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 2 BLAS. ! -- 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 real(sp), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars real(sp) :: ajj, sstop, stemp integer(${ik}$) :: i, itemp, j, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPSTF2', -info ) return end if ! quick return if possible if( n==0 )return ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value pvt = 1_${ik}$ ajj = a( pvt, pvt ) do i = 2, n if( a( i, i )>ajj ) then pvt = i ajj = a( pvt, pvt ) end if end do if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 170 end if ! compute stopping value if not supplied if( tol<zero ) then sstop = n * stdlib${ii}$_slamch( 'EPSILON' ) * ajj else sstop = tol end if ! set first half of work to zero, holds dot products do i = 1, n work( i ) = 0_${ik}$ end do if( upper ) then ! compute the cholesky factorization p**t * a * p = u**t * u loop_130: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) + a( j-1, i )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 160 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_sswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_sswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda ) call stdlib${ii}$_sswap( pvt-j-1, a( j, j+1 ), lda, a( j+1, pvt ), 1_${ik}$ ) ! swap dot products and piv stemp = work( j ) work( j ) = work( pvt ) work( pvt ) = stemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j if( j<n ) then call stdlib${ii}$_sgemv( 'TRANS', j-1, n-j, -one, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, & one, a( j, j+1 ), lda ) call stdlib${ii}$_sscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_130 else ! compute the cholesky factorization p**t * a * p = l * l**t loop_150: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) + a( i, j-1 )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 160 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_sswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_sswap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ ) call stdlib${ii}$_sswap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ), lda ) ! swap dot products and piv stemp = work( j ) work( j ) = work( pvt ) work( pvt ) = stemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j if( j<n ) then call stdlib${ii}$_sgemv( 'NO TRANS', n-j, j-1, -one, a( j+1, 1_${ik}$ ), lda,a( j, 1_${ik}$ ), & lda, one, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_sscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_150 end if ! ran to completion, a has full rank rank = n go to 170 160 continue ! rank is number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 170 continue return end subroutine stdlib${ii}$_spstf2 pure module subroutine stdlib${ii}$_dpstf2( uplo, n, a, lda, piv, rank, tol, work, info ) !! DPSTF2 computes the Cholesky factorization with complete !! pivoting of a real symmetric positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**T * U , if UPLO = 'U', !! P**T * A * P = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 2 BLAS. ! -- 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 real(dp), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars real(dp) :: ajj, dstop, dtemp integer(${ik}$) :: i, itemp, j, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPSTF2', -info ) return end if ! quick return if possible if( n==0 )return ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value pvt = 1_${ik}$ ajj = a( pvt, pvt ) do i = 2, n if( a( i, i )>ajj ) then pvt = i ajj = a( pvt, pvt ) end if end do if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 170 end if ! compute stopping value if not supplied if( tol<zero ) then dstop = n * stdlib${ii}$_dlamch( 'EPSILON' ) * ajj else dstop = tol end if ! set first half of work to zero, holds dot products do i = 1, n work( i ) = 0_${ik}$ end do if( upper ) then ! compute the cholesky factorization p**t * a * p = u**t * u loop_130: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) + a( j-1, i )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 160 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_dswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_dswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda ) call stdlib${ii}$_dswap( pvt-j-1, a( j, j+1 ), lda, a( j+1, pvt ), 1_${ik}$ ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j if( j<n ) then call stdlib${ii}$_dgemv( 'TRANS', j-1, n-j, -one, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, & one, a( j, j+1 ), lda ) call stdlib${ii}$_dscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_130 else ! compute the cholesky factorization p**t * a * p = l * l**t loop_150: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) + a( i, j-1 )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 160 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_dswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_dswap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ ) call stdlib${ii}$_dswap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ), lda ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j if( j<n ) then call stdlib${ii}$_dgemv( 'NO TRANS', n-j, j-1, -one, a( j+1, 1_${ik}$ ), lda,a( j, 1_${ik}$ ), & lda, one, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_150 end if ! ran to completion, a has full rank rank = n go to 170 160 continue ! rank is number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 170 continue return end subroutine stdlib${ii}$_dpstf2 #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$pstf2( uplo, n, a, lda, piv, rank, tol, work, info ) !! DPSTF2: computes the Cholesky factorization with complete !! pivoting of a real symmetric positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**T * U , if UPLO = 'U', !! P**T * A * P = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 2 BLAS. ! -- 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 real(${rk}$), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars real(${rk}$) :: ajj, dstop, dtemp integer(${ik}$) :: i, itemp, j, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPSTF2', -info ) return end if ! quick return if possible if( n==0 )return ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value pvt = 1_${ik}$ ajj = a( pvt, pvt ) do i = 2, n if( a( i, i )>ajj ) then pvt = i ajj = a( pvt, pvt ) end if end do if( ajj<=zero.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 170 end if ! compute stopping value if not supplied if( tol<zero ) then dstop = n * stdlib${ii}$_${ri}$lamch( 'EPSILON' ) * ajj else dstop = tol end if ! set first half of work to zero, holds dot products do i = 1, n work( i ) = 0_${ik}$ end do if( upper ) then ! compute the cholesky factorization p**t * a * p = u**t * u loop_130: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) + a( j-1, i )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then a( j, j ) = ajj go to 160 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_${ri}$swap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_${ri}$swap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda ) call stdlib${ii}$_${ri}$swap( pvt-j-1, a( j, j+1 ), lda, a( j+1, pvt ), 1_${ik}$ ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j if( j<n ) then call stdlib${ii}$_${ri}$gemv( 'TRANS', j-1, n-j, -one, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, & one, a( j, j+1 ), lda ) call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_130 else ! compute the cholesky factorization p**t * a * p = l * l**t loop_150: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second half of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) + a( i, j-1 )**2_${ik}$ end if work( n+i ) = a( i, i ) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then a( j, j ) = ajj go to 160 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_${ri}$swap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_${ri}$swap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ ) call stdlib${ii}$_${ri}$swap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ), lda ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j if( j<n ) then call stdlib${ii}$_${ri}$gemv( 'NO TRANS', n-j, j-1, -one, a( j+1, 1_${ik}$ ), lda,a( j, 1_${ik}$ ), & lda, one, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_150 end if ! ran to completion, a has full rank rank = n go to 170 160 continue ! rank is number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 170 continue return end subroutine stdlib${ii}$_${ri}$pstf2 #:endif #:endfor pure module subroutine stdlib${ii}$_cpstf2( uplo, n, a, lda, piv, rank, tol, work, info ) !! CPSTF2 computes the Cholesky factorization with complete !! pivoting of a complex Hermitian positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**H * U , if UPLO = 'U', !! P**T * A * P = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 2 BLAS. ! -- 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 real(sp), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments complex(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars complex(sp) :: ctemp real(sp) :: ajj, sstop, stemp integer(${ik}$) :: i, itemp, j, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPSTF2', -info ) return end if ! quick return if possible if( n==0 )return ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value do i = 1, n work( i ) = real( a( i, i ),KIND=sp) end do pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ ) ajj = real( a( pvt, pvt ),KIND=sp) if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 200 end if ! compute stopping value if not supplied if( tol<zero ) then sstop = n * stdlib${ii}$_slamch( 'EPSILON' ) * ajj else sstop = tol end if ! set first chalf of work to zero, holds dot products do i = 1, n work( i ) = 0_${ik}$ end do if( upper ) then ! compute the cholesky factorization p**t * a * p = u**h * u loop_150: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=sp) end if work( n+i ) = real( a( i, i ),KIND=sp) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_cswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_cswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda ) do i = j + 1, pvt - 1 ctemp = conjg( a( j, i ) ) a( j, i ) = conjg( a( i, pvt ) ) a( i, pvt ) = ctemp end do a( j, pvt ) = conjg( a( j, pvt ) ) ! swap dot products and piv stemp = work( j ) work( j ) = work( pvt ) work( pvt ) = stemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j if( j<n ) then call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_cgemv( 'TRANS', j-1, n-j, -cone, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, & cone, a( j, j+1 ), lda ) call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_csscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_150 else ! compute the cholesky factorization p**t * a * p = l * l**h loop_180: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=sp) end if work( n+i ) = real( a( i, i ),KIND=sp) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_cswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_cswap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ ) do i = j + 1, pvt - 1 ctemp = conjg( a( i, j ) ) a( i, j ) = conjg( a( pvt, i ) ) a( pvt, i ) = ctemp end do a( pvt, j ) = conjg( a( pvt, j ) ) ! swap dot products and piv stemp = work( j ) work( j ) = work( pvt ) work( pvt ) = stemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j if( j<n ) then call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_cgemv( 'NO TRANS', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), & lda, cone, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_csscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_180 end if ! ran to completion, a has full rank rank = n go to 200 190 continue ! rank is number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 200 continue return end subroutine stdlib${ii}$_cpstf2 pure module subroutine stdlib${ii}$_zpstf2( uplo, n, a, lda, piv, rank, tol, work, info ) !! ZPSTF2 computes the Cholesky factorization with complete !! pivoting of a complex Hermitian positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**H * U , if UPLO = 'U', !! P**T * A * P = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 2 BLAS. ! -- 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 real(dp), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments complex(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars complex(dp) :: ztemp real(dp) :: ajj, dstop, dtemp integer(${ik}$) :: i, itemp, j, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPSTF2', -info ) return end if ! quick return if possible if( n==0 )return ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value do i = 1, n work( i ) = real( a( i, i ),KIND=dp) end do pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ ) ajj = real( a( pvt, pvt ),KIND=dp) if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 200 end if ! compute stopping value if not supplied if( tol<zero ) then dstop = n * stdlib${ii}$_dlamch( 'EPSILON' ) * ajj else dstop = tol end if ! set first chalf of work to zero, holds dot products do i = 1, n work( i ) = 0_${ik}$ end do if( upper ) then ! compute the cholesky factorization p**t * a * p = u**h* u loop_150: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=dp) end if work( n+i ) = real( a( i, i ),KIND=dp) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_zswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_zswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda ) do i = j + 1, pvt - 1 ztemp = conjg( a( j, i ) ) a( j, i ) = conjg( a( i, pvt ) ) a( i, pvt ) = ztemp end do a( j, pvt ) = conjg( a( j, pvt ) ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j if( j<n ) then call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_zgemv( 'TRANS', j-1, n-j, -cone, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, & cone, a( j, j+1 ), lda ) call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_zdscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_150 else ! compute the cholesky factorization p**t * a * p = l * l**h loop_180: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=dp) end if work( n+i ) = real( a( i, i ),KIND=dp) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_zswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_zswap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ ) do i = j + 1, pvt - 1 ztemp = conjg( a( i, j ) ) a( i, j ) = conjg( a( pvt, i ) ) a( pvt, i ) = ztemp end do a( pvt, j ) = conjg( a( pvt, j ) ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j if( j<n ) then call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_zgemv( 'NO TRANS', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), & lda, cone, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_zdscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_180 end if ! ran to completion, a has full rank rank = n go to 200 190 continue ! rank is number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 200 continue return end subroutine stdlib${ii}$_zpstf2 #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$pstf2( uplo, n, a, lda, piv, rank, tol, work, info ) !! ZPSTF2: computes the Cholesky factorization with complete !! pivoting of a complex Hermitian positive semidefinite matrix A. !! The factorization has the form !! P**T * A * P = U**H * U , if UPLO = 'U', !! P**T * A * P = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular, and !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 2 BLAS. ! -- 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 real(${ck}$), intent(in) :: tol integer(${ik}$), intent(out) :: info, rank integer(${ik}$), intent(in) :: lda, n character, intent(in) :: uplo ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) real(${ck}$), intent(out) :: work(2_${ik}$*n) integer(${ik}$), intent(out) :: piv(n) ! ===================================================================== ! Local Scalars complex(${ck}$) :: ztemp real(${ck}$) :: ajj, dstop, dtemp integer(${ik}$) :: i, itemp, j, pvt logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPSTF2', -info ) return end if ! quick return if possible if( n==0 )return ! initialize piv do i = 1, n piv( i ) = i end do ! compute stopping value do i = 1, n work( i ) = real( a( i, i ),KIND=${ck}$) end do pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ ) ajj = real( a( pvt, pvt ),KIND=${ck}$) if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then rank = 0_${ik}$ info = 1_${ik}$ go to 200 end if ! compute stopping value if not supplied if( tol<zero ) then dstop = n * stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) * ajj else dstop = tol end if ! set first chalf of work to zero, holds dot products do i = 1, n work( i ) = 0_${ik}$ end do if( upper ) then ! compute the cholesky factorization p**t * a * p = u**h* u loop_150: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=${ck}$) end if work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_${ci}$swap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ ) if( pvt<n )call stdlib${ii}$_${ci}$swap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda ) do i = j + 1, pvt - 1 ztemp = conjg( a( j, i ) ) a( j, i ) = conjg( a( i, pvt ) ) a( i, pvt ) = ztemp end do a( j, pvt ) = conjg( a( j, pvt ) ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of row j if( j<n ) then call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_${ci}$gemv( 'TRANS', j-1, n-j, -cone, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, & cone, a( j, j+1 ), lda ) call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ ) call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j, j+1 ), lda ) end if end do loop_150 else ! compute the cholesky factorization p**t * a * p = l * l**h loop_180: do j = 1, n ! find pivot, test for exit, else swap rows and columns ! update dot products, compute possible pivots which are ! stored in the second chalf of work do i = j, n if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=${ck}$) end if work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i ) end do if( j>1_${ik}$ ) then itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 190 end if end if if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) call stdlib${ii}$_${ci}$swap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda ) if( pvt<n )call stdlib${ii}$_${ci}$swap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ ) do i = j + 1, pvt - 1 ztemp = conjg( a( i, j ) ) a( i, j ) = conjg( a( pvt, i ) ) a( pvt, i ) = ztemp end do a( pvt, j ) = conjg( a( pvt, j ) ) ! swap dot products and piv dtemp = work( j ) work( j ) = work( pvt ) work( pvt ) = dtemp itemp = piv( pvt ) piv( pvt ) = piv( j ) piv( j ) = itemp end if ajj = sqrt( ajj ) a( j, j ) = ajj ! compute elements j+1:n of column j if( j<n ) then call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_${ci}$gemv( 'NO TRANS', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), & lda, cone, a( j+1, j ), 1_${ik}$ ) call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda ) call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ ) end if end do loop_180 end if ! ran to completion, a has full rank rank = n go to 200 190 continue ! rank is number of steps completed. set info = 1 to signal ! that the factorization cannot be used to solve a system. rank = j - 1_${ik}$ info = 1_${ik}$ 200 continue return end subroutine stdlib${ii}$_${ci}$pstf2 #:endif #:endfor pure module subroutine stdlib${ii}$_spotrs( uplo, n, nrhs, a, lda, b, ldb, info ) !! SPOTRS solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A using the Cholesky factorization !! A = U**T*U or A = L*L**T computed by SPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldb, n, nrhs ! Array Arguments real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPOTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**t *u. ! solve u**t *x = b, overwriting b with x. call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,& ldb ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,& b, ldb ) else ! solve a*x = b where a = l*l**t. ! solve l*x = b, overwriting b with x. call stdlib${ii}$_strsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,& b, ldb ) ! solve l**t *x = b, overwriting b with x. call stdlib${ii}$_strsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,& ldb ) end if return end subroutine stdlib${ii}$_spotrs pure module subroutine stdlib${ii}$_dpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) !! DPOTRS solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A using the Cholesky factorization !! A = U**T*U or A = L*L**T computed by DPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldb, n, nrhs ! Array Arguments real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**t *u. ! solve u**t *x = b, overwriting b with x. call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,& ldb ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,& b, ldb ) else ! solve a*x = b where a = l*l**t. ! solve l*x = b, overwriting b with x. call stdlib${ii}$_dtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,& b, ldb ) ! solve l**t *x = b, overwriting b with x. call stdlib${ii}$_dtrsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,& ldb ) end if return end subroutine stdlib${ii}$_dpotrs #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$potrs( uplo, n, nrhs, a, lda, b, ldb, info ) !! DPOTRS: solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A using the Cholesky factorization !! A = U**T*U or A = L*L**T computed by DPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldb, n, nrhs ! Array Arguments real(${rk}$), intent(in) :: a(lda,*) real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**t *u. ! solve u**t *x = b, overwriting b with x. call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,& ldb ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,& b, ldb ) else ! solve a*x = b where a = l*l**t. ! solve l*x = b, overwriting b with x. call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,& b, ldb ) ! solve l**t *x = b, overwriting b with x. call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,& ldb ) end if return end subroutine stdlib${ii}$_${ri}$potrs #:endif #:endfor pure module subroutine stdlib${ii}$_cpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) !! CPOTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by CPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldb, n, nrhs ! Array Arguments complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPOTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**h *u. ! solve u**h *x = b, overwriting b with x. call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,& a, lda, b, ldb ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, & lda, b, ldb ) else ! solve a*x = b where a = l*l**h. ! solve l*x = b, overwriting b with x. call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, & lda, b, ldb ) ! solve l**h *x = b, overwriting b with x. call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,& a, lda, b, ldb ) end if return end subroutine stdlib${ii}$_cpotrs pure module subroutine stdlib${ii}$_zpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) !! ZPOTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H * U or A = L * L**H computed by ZPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldb, n, nrhs ! Array Arguments complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**h *u. ! solve u**h *x = b, overwriting b with x. call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,& a, lda, b, ldb ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, & lda, b, ldb ) else ! solve a*x = b where a = l*l**h. ! solve l*x = b, overwriting b with x. call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, & lda, b, ldb ) ! solve l**h *x = b, overwriting b with x. call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,& a, lda, b, ldb ) end if return end subroutine stdlib${ii}$_zpotrs #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$potrs( uplo, n, nrhs, a, lda, b, ldb, info ) !! ZPOTRS: solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H * U or A = L * L**H computed by ZPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldb, n, nrhs ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**h *u. ! solve u**h *x = b, overwriting b with x. call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,& a, lda, b, ldb ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, & lda, b, ldb ) else ! solve a*x = b where a = l*l**h. ! solve l*x = b, overwriting b with x. call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, & lda, b, ldb ) ! solve l**h *x = b, overwriting b with x. call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,& a, lda, b, ldb ) end if return end subroutine stdlib${ii}$_${ci}$potrs #:endif #:endfor pure module subroutine stdlib${ii}$_spotri( uplo, n, a, lda, info ) !! SPOTRI computes the inverse of a real symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by SPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPOTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_strtri( uplo, 'NON-UNIT', n, a, lda, info ) if( info>0 )return ! form inv(u) * inv(u)**t or inv(l)**t * inv(l). call stdlib${ii}$_slauum( uplo, n, a, lda, info ) return end subroutine stdlib${ii}$_spotri pure module subroutine stdlib${ii}$_dpotri( uplo, n, a, lda, info ) !! DPOTRI computes the inverse of a real symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by DPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_dtrtri( uplo, 'NON-UNIT', n, a, lda, info ) if( info>0 )return ! form inv(u) * inv(u)**t or inv(l)**t * inv(l). call stdlib${ii}$_dlauum( uplo, n, a, lda, info ) return end subroutine stdlib${ii}$_dpotri #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$potri( uplo, n, a, lda, info ) !! DPOTRI: computes the inverse of a real symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by DPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_${ri}$trtri( uplo, 'NON-UNIT', n, a, lda, info ) if( info>0 )return ! form inv(u) * inv(u)**t or inv(l)**t * inv(l). call stdlib${ii}$_${ri}$lauum( uplo, n, a, lda, info ) return end subroutine stdlib${ii}$_${ri}$potri #:endif #:endfor pure module subroutine stdlib${ii}$_cpotri( uplo, n, a, lda, info ) !! CPOTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by CPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPOTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_ctrtri( uplo, 'NON-UNIT', n, a, lda, info ) if( info>0 )return ! form inv(u) * inv(u)**h or inv(l)**h * inv(l). call stdlib${ii}$_clauum( uplo, n, a, lda, info ) return end subroutine stdlib${ii}$_cpotri pure module subroutine stdlib${ii}$_zpotri( uplo, n, a, lda, info ) !! ZPOTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_ztrtri( uplo, 'NON-UNIT', n, a, lda, info ) if( info>0 )return ! form inv(u) * inv(u)**h or inv(l)**h * inv(l). call stdlib${ii}$_zlauum( uplo, n, a, lda, info ) return end subroutine stdlib${ii}$_zpotri #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$potri( uplo, n, a, lda, info ) !! ZPOTRI: computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPOTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_${ci}$trtri( uplo, 'NON-UNIT', n, a, lda, info ) if( info>0 )return ! form inv(u) * inv(u)**h or inv(l)**h * inv(l). call stdlib${ii}$_${ci}$lauum( uplo, n, a, lda, info ) return end subroutine stdlib${ii}$_${ci}$potri #:endif #:endfor pure module subroutine stdlib${ii}$_sporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, & !! SPORFS improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric positive definite, !! and provides error bounds and backward error estimates for the !! solution. work, iwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) real(sp), intent(out) :: berr(*), ferr(*), work(*) real(sp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, j, k, kase, nz real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldaf<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -9_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -11_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPORFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_slamch( 'EPSILON' ) safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_scopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ ) call stdlib${ii}$_ssymv( uplo, n, -one, a, lda, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n work( i ) = abs( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). if( upper ) then do k = 1, n s = zero xk = abs( x( k, j ) ) do i = 1, k - 1 work( i ) = work( i ) + abs( a( i, k ) )*xk s = s + abs( a( i, k ) )*abs( x( i, j ) ) end do work( k ) = work( k ) + abs( a( k, k ) )*xk + s end do else do k = 1, n s = zero xk = abs( x( k, j ) ) work( k ) = work( k ) + abs( a( k, k ) )*xk do i = k + 1, n work( i ) = work( i ) + abs( a( i, k ) )*xk s = s + abs( a( i, k ) )*abs( x( i, j ) ) end do work( k ) = work( k ) + s end do end if s = zero do i = 1, n if( work( i )>safe2 ) then s = max( s, abs( work( n+i ) ) / work( i ) ) else s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_spotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info ) call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_slacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( work( i )>safe2 ) then work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) else work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_slacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). call stdlib${ii}$_spotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( n+i ) = work( i )*work( n+i ) end do call stdlib${ii}$_spotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, abs( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_sporfs pure module subroutine stdlib${ii}$_dporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, & !! DPORFS improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric positive definite, !! and provides error bounds and backward error estimates for the !! solution. work, iwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) real(dp), intent(out) :: berr(*), ferr(*), work(*) real(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, j, k, kase, nz real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldaf<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -9_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -11_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPORFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_dlamch( 'EPSILON' ) safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_dcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ ) call stdlib${ii}$_dsymv( uplo, n, -one, a, lda, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n work( i ) = abs( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). if( upper ) then do k = 1, n s = zero xk = abs( x( k, j ) ) do i = 1, k - 1 work( i ) = work( i ) + abs( a( i, k ) )*xk s = s + abs( a( i, k ) )*abs( x( i, j ) ) end do work( k ) = work( k ) + abs( a( k, k ) )*xk + s end do else do k = 1, n s = zero xk = abs( x( k, j ) ) work( k ) = work( k ) + abs( a( k, k ) )*xk do i = k + 1, n work( i ) = work( i ) + abs( a( i, k ) )*xk s = s + abs( a( i, k ) )*abs( x( i, j ) ) end do work( k ) = work( k ) + s end do end if s = zero do i = 1, n if( work( i )>safe2 ) then s = max( s, abs( work( n+i ) ) / work( i ) ) else s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_dpotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info ) call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_dlacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( work( i )>safe2 ) then work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) else work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_dlacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). call stdlib${ii}$_dpotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( n+i ) = work( i )*work( n+i ) end do call stdlib${ii}$_dpotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, abs( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_dporfs #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$porfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, & !! DPORFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric positive definite, !! and provides error bounds and backward error estimates for the !! solution. work, iwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) real(${rk}$), intent(out) :: berr(*), ferr(*), work(*) real(${rk}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, j, k, kase, nz real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldaf<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -9_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -11_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPORFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' ) safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_${ri}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ ) call stdlib${ii}$_${ri}$symv( uplo, n, -one, a, lda, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n work( i ) = abs( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). if( upper ) then do k = 1, n s = zero xk = abs( x( k, j ) ) do i = 1, k - 1 work( i ) = work( i ) + abs( a( i, k ) )*xk s = s + abs( a( i, k ) )*abs( x( i, j ) ) end do work( k ) = work( k ) + abs( a( k, k ) )*xk + s end do else do k = 1, n s = zero xk = abs( x( k, j ) ) work( k ) = work( k ) + abs( a( k, k ) )*xk do i = k + 1, n work( i ) = work( i ) + abs( a( i, k ) )*xk s = s + abs( a( i, k ) )*abs( x( i, j ) ) end do work( k ) = work( k ) + s end do end if s = zero do i = 1, n if( work( i )>safe2 ) then s = max( s, abs( work( n+i ) ) / work( i ) ) else s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_${ri}$potrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info ) call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( work( i )>safe2 ) then work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) else work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_${ri}$lacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). call stdlib${ii}$_${ri}$potrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( n+i ) = work( i )*work( n+i ) end do call stdlib${ii}$_${ri}$potrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, abs( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_${ri}$porfs #:endif #:endfor pure module subroutine stdlib${ii}$_cporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, & !! CPORFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite, !! and provides error bounds and backward error estimates for the !! solution. work, rwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments real(sp), intent(out) :: berr(*), ferr(*), rwork(*) complex(sp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) ! ==================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, j, k, kase, nz real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(sp) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(sp) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldaf<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -9_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -11_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPORFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_slamch( 'EPSILON' ) safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_ccopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ ) call stdlib${ii}$_chemv( uplo, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n rwork( i ) = cabs1( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). if( upper ) then do k = 1, n s = zero xk = cabs1( x( k, j ) ) do i = 1, k - 1 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) ) end do rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=sp) )*xk + s end do else do k = 1, n s = zero xk = cabs1( x( k, j ) ) rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=sp) )*xk do i = k + 1, n rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) ) end do rwork( k ) = rwork( k ) + s end do end if s = zero do i = 1, n if( rwork( i )>safe2 ) then s = max( s, cabs1( work( i ) ) / rwork( i ) ) else s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_cpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_clacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( rwork( i )>safe2 ) then rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) else rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). call stdlib${ii}$_cpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do call stdlib${ii}$_cpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, cabs1( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_cporfs pure module subroutine stdlib${ii}$_zporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, & !! ZPORFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite, !! and provides error bounds and backward error estimates for the !! solution. work, rwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments real(dp), intent(out) :: berr(*), ferr(*), rwork(*) complex(dp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) ! ==================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, j, k, kase, nz real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(dp) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(dp) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldaf<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -9_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -11_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPORFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_dlamch( 'EPSILON' ) safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_zcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ ) call stdlib${ii}$_zhemv( uplo, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n rwork( i ) = cabs1( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). if( upper ) then do k = 1, n s = zero xk = cabs1( x( k, j ) ) do i = 1, k - 1 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) ) end do rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=dp) )*xk + s end do else do k = 1, n s = zero xk = cabs1( x( k, j ) ) rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=dp) )*xk do i = k + 1, n rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) ) end do rwork( k ) = rwork( k ) + s end do end if s = zero do i = 1, n if( rwork( i )>safe2 ) then s = max( s, cabs1( work( i ) ) / rwork( i ) ) else s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_zpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_zlacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( rwork( i )>safe2 ) then rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) else rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). call stdlib${ii}$_zpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do call stdlib${ii}$_zpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, cabs1( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_zporfs #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$porfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, & !! ZPORFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite, !! and provides error bounds and backward error estimates for the !! solution. work, rwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(inout) :: x(ldx,*) ! ==================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, j, k, kase, nz real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk complex(${ck}$) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(${ck}$) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -5_${ik}$ else if( ldaf<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -9_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -11_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPORFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_${ci}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ ) call stdlib${ii}$_${ci}$hemv( uplo, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n rwork( i ) = cabs1( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). if( upper ) then do k = 1, n s = zero xk = cabs1( x( k, j ) ) do i = 1, k - 1 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) ) end do rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=${ck}$) )*xk + s end do else do k = 1, n s = zero xk = cabs1( x( k, j ) ) rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=${ck}$) )*xk do i = k + 1, n rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) ) end do rwork( k ) = rwork( k ) + s end do end if s = zero do i = 1, n if( rwork( i )>safe2 ) then s = max( s, cabs1( work( i ) ) / rwork( i ) ) else s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_${ci}$potrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( rwork( i )>safe2 ) then rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) else rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). call stdlib${ii}$_${ci}$potrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do call stdlib${ii}$_${ci}$potrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, cabs1( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_${ci}$porfs #:endif #:endfor pure module subroutine stdlib${ii}$_spoequ( n, a, lda, s, scond, amax, info ) !! SPOEQU computes row and column scalings intended to equilibrate a !! symmetric positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(sp), intent(out) :: amax, scond ! Array Arguments real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: s(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(sp) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPOEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = a( i, i ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_spoequ pure module subroutine stdlib${ii}$_dpoequ( n, a, lda, s, scond, amax, info ) !! DPOEQU computes row and column scalings intended to equilibrate a !! symmetric positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(dp), intent(out) :: amax, scond ! Array Arguments real(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: s(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(dp) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = a( i, i ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_dpoequ #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$poequ( n, a, lda, s, scond, amax, info ) !! DPOEQU: computes row and column scalings intended to equilibrate a !! symmetric positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(${rk}$), intent(out) :: amax, scond ! Array Arguments real(${rk}$), intent(in) :: a(lda,*) real(${rk}$), intent(out) :: s(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(${rk}$) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = a( i, i ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_${ri}$poequ #:endif #:endfor pure module subroutine stdlib${ii}$_cpoequ( n, a, lda, s, scond, amax, info ) !! CPOEQU computes row and column scalings intended to equilibrate a !! Hermitian positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(sp), intent(out) :: amax, scond ! Array Arguments real(sp), intent(out) :: s(*) complex(sp), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(sp) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPOEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = real( a( i, i ),KIND=sp) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_cpoequ pure module subroutine stdlib${ii}$_zpoequ( n, a, lda, s, scond, amax, info ) !! ZPOEQU computes row and column scalings intended to equilibrate a !! Hermitian positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(dp), intent(out) :: amax, scond ! Array Arguments real(dp), intent(out) :: s(*) complex(dp), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(dp) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = real( a( i, i ),KIND=dp) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_zpoequ #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$poequ( n, a, lda, s, scond, amax, info ) !! ZPOEQU: computes row and column scalings intended to equilibrate a !! Hermitian positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(${ck}$), intent(out) :: amax, scond ! Array Arguments real(${ck}$), intent(out) :: s(*) complex(${ck}$), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(${ck}$) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = real( a( i, i ),KIND=${ck}$) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_${ci}$poequ #:endif #:endfor pure module subroutine stdlib${ii}$_spoequb( n, a, lda, s, scond, amax, info ) !! SPOEQUB computes row and column scalings intended to equilibrate a !! symmetric positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. !! This routine differs from SPOEQU by restricting the scaling factors !! to a power of the radix. Barring over- and underflow, scaling by !! these factors introduces no additional rounding errors. However, the !! scaled diagonal entries are no longer approximately 1 but lie !! between sqrt(radix) and 1/sqrt(radix). ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(sp), intent(out) :: amax, scond ! Array Arguments real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: s(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(sp) :: smin, base, tmp ! Intrinsic Functions ! Executable Statements ! test the input parameters. ! positive definite only performs 1 pass of equilibration. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPOEQUB', -info ) return end if ! quick return if possible. if( n==0_${ik}$ ) then scond = one amax = zero return end if base = stdlib${ii}$_slamch( 'B' ) tmp = -0.5_sp / log ( base ) ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = a( i, i ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$) end do ! compute scond = min(s(i)) / max(s(i)). scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_spoequb pure module subroutine stdlib${ii}$_dpoequb( n, a, lda, s, scond, amax, info ) !! DPOEQUB computes row and column scalings intended to equilibrate a !! symmetric positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. !! This routine differs from DPOEQU by restricting the scaling factors !! to a power of the radix. Barring over- and underflow, scaling by !! these factors introduces no additional rounding errors. However, the !! scaled diagonal entries are no longer approximately 1 but lie !! between sqrt(radix) and 1/sqrt(radix). ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(dp), intent(out) :: amax, scond ! Array Arguments real(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: s(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(dp) :: smin, base, tmp ! Intrinsic Functions ! Executable Statements ! test the input parameters. ! positive definite only performs 1 pass of equilibration. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOEQUB', -info ) return end if ! quick return if possible. if( n==0_${ik}$ ) then scond = one amax = zero return end if base = stdlib${ii}$_dlamch( 'B' ) tmp = -0.5e+0_dp / log ( base ) ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = a( i, i ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$) end do ! compute scond = min(s(i)) / max(s(i)). scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_dpoequb #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$poequb( n, a, lda, s, scond, amax, info ) !! DPOEQUB: computes row and column scalings intended to equilibrate a !! symmetric positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. !! This routine differs from DPOEQU by restricting the scaling factors !! to a power of the radix. Barring over- and underflow, scaling by !! these factors introduces no additional rounding errors. However, the !! scaled diagonal entries are no longer approximately 1 but lie !! between sqrt(radix) and 1/sqrt(radix). ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(${rk}$), intent(out) :: amax, scond ! Array Arguments real(${rk}$), intent(in) :: a(lda,*) real(${rk}$), intent(out) :: s(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(${rk}$) :: smin, base, tmp ! Intrinsic Functions ! Executable Statements ! test the input parameters. ! positive definite only performs 1 pass of equilibration. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPOEQUB', -info ) return end if ! quick return if possible. if( n==0_${ik}$ ) then scond = one amax = zero return end if base = stdlib${ii}$_${ri}$lamch( 'B' ) tmp = -0.5e+0_${rk}$ / log ( base ) ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = a( i, i ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$) end do ! compute scond = min(s(i)) / max(s(i)). scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_${ri}$poequb #:endif #:endfor pure module subroutine stdlib${ii}$_cpoequb( n, a, lda, s, scond, amax, info ) !! CPOEQUB computes row and column scalings intended to equilibrate a !! Hermitian positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. !! This routine differs from CPOEQU by restricting the scaling factors !! to a power of the radix. Barring over- and underflow, scaling by !! these factors introduces no additional rounding errors. However, the !! scaled diagonal entries are no longer approximately 1 but lie !! between sqrt(radix) and 1/sqrt(radix). ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(sp), intent(out) :: amax, scond ! Array Arguments complex(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: s(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(sp) :: smin, base, tmp ! Intrinsic Functions ! Executable Statements ! test the input parameters. ! positive definite only performs 1 pass of equilibration. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPOEQUB', -info ) return end if ! quick return if possible. if( n==0_${ik}$ ) then scond = one amax = zero return end if base = stdlib${ii}$_slamch( 'B' ) tmp = -0.5_sp / log ( base ) ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = real( a( i, i ),KIND=sp) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$) end do ! compute scond = min(s(i)) / max(s(i)). scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_cpoequb pure module subroutine stdlib${ii}$_zpoequb( n, a, lda, s, scond, amax, info ) !! ZPOEQUB computes row and column scalings intended to equilibrate a !! Hermitian positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. !! This routine differs from ZPOEQU by restricting the scaling factors !! to a power of the radix. Barring over- and underflow, scaling by !! these factors introduces no additional rounding errors. However, the !! scaled diagonal entries are no longer approximately 1 but lie !! between sqrt(radix) and 1/sqrt(radix). ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(dp), intent(out) :: amax, scond ! Array Arguments complex(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: s(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(dp) :: smin, base, tmp ! Intrinsic Functions ! Executable Statements ! test the input parameters. ! positive definite only performs 1 pass of equilibration. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOEQUB', -info ) return end if ! quick return if possible. if( n==0_${ik}$ ) then scond = one amax = zero return end if base = stdlib${ii}$_dlamch( 'B' ) tmp = -0.5e+0_dp / log ( base ) ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = real( a( i, i ),KIND=dp) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$) end do ! compute scond = min(s(i)) / max(s(i)). scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_zpoequb #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$poequb( n, a, lda, s, scond, amax, info ) !! ZPOEQUB: computes row and column scalings intended to equilibrate a !! Hermitian positive definite matrix A and reduce its condition number !! (with respect to the two-norm). S contains the scale factors, !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. !! This routine differs from ZPOEQU by restricting the scaling factors !! to a power of the radix. Barring over- and underflow, scaling by !! these factors introduces no additional rounding errors. However, the !! scaled diagonal entries are no longer approximately 1 but lie !! between sqrt(radix) and 1/sqrt(radix). ! -- 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 integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: lda, n real(${ck}$), intent(out) :: amax, scond ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) real(${ck}$), intent(out) :: s(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i real(${ck}$) :: smin, base, tmp ! Intrinsic Functions ! Executable Statements ! test the input parameters. ! positive definite only performs 1 pass of equilibration. info = 0_${ik}$ if( n<0_${ik}$ ) then info = -1_${ik}$ else if( lda<max( 1_${ik}$, n ) ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPOEQUB', -info ) return end if ! quick return if possible. if( n==0_${ik}$ ) then scond = one amax = zero return end if base = stdlib${ii}$_${c2ri(ci)}$lamch( 'B' ) tmp = -0.5e+0_${ck}$ / log ( base ) ! find the minimum and maximum diagonal elements. s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) do i = 2, n s( i ) = real( a( i, i ),KIND=${ck}$) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$) end do ! compute scond = min(s(i)) / max(s(i)). scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_${ci}$poequb #:endif #:endfor pure module subroutine stdlib${ii}$_claqhe( uplo, n, a, lda, s, scond, amax, equed ) !! CLAQHE equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- 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(out) :: equed character, intent(in) :: uplo integer(${ik}$), intent(in) :: lda, n real(sp), intent(in) :: amax, scond ! Array Arguments real(sp), intent(in) :: s(*) complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters real(sp), parameter :: thresh = 0.1e+0_sp ! Local Scalars integer(${ik}$) :: i, j real(sp) :: cj, large, small ! Intrinsic Functions ! Executable Statements ! quick return if possible if( n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration equed = 'N' else ! replace a by diag(s) * a * diag(s). if( stdlib_lsame( uplo, 'U' ) ) then ! upper triangle of a is stored. do j = 1, n cj = s( j ) do i = 1, j - 1 a( i, j ) = cj*s( i )*a( i, j ) end do a( j, j ) = cj*cj*real( a( j, j ),KIND=sp) end do else ! lower triangle of a is stored. do j = 1, n cj = s( j ) a( j, j ) = cj*cj*real( a( j, j ),KIND=sp) do i = j + 1, n a( i, j ) = cj*s( i )*a( i, j ) end do end do end if equed = 'Y' end if return end subroutine stdlib${ii}$_claqhe pure module subroutine stdlib${ii}$_zlaqhe( uplo, n, a, lda, s, scond, amax, equed ) !! ZLAQHE equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- 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(out) :: equed character, intent(in) :: uplo integer(${ik}$), intent(in) :: lda, n real(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(in) :: s(*) complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars integer(${ik}$) :: i, j real(dp) :: cj, large, small ! Intrinsic Functions ! Executable Statements ! quick return if possible if( n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration equed = 'N' else ! replace a by diag(s) * a * diag(s). if( stdlib_lsame( uplo, 'U' ) ) then ! upper triangle of a is stored. do j = 1, n cj = s( j ) do i = 1, j - 1 a( i, j ) = cj*s( i )*a( i, j ) end do a( j, j ) = cj*cj*real( a( j, j ),KIND=dp) end do else ! lower triangle of a is stored. do j = 1, n cj = s( j ) a( j, j ) = cj*cj*real( a( j, j ),KIND=dp) do i = j + 1, n a( i, j ) = cj*s( i )*a( i, j ) end do end do end if equed = 'Y' end if return end subroutine stdlib${ii}$_zlaqhe #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$laqhe( uplo, n, a, lda, s, scond, amax, equed ) !! ZLAQHE: equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- 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(out) :: equed character, intent(in) :: uplo integer(${ik}$), intent(in) :: lda, n real(${ck}$), intent(in) :: amax, scond ! Array Arguments real(${ck}$), intent(in) :: s(*) complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars integer(${ik}$) :: i, j real(${ck}$) :: cj, large, small ! Intrinsic Functions ! Executable Statements ! quick return if possible if( n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration equed = 'N' else ! replace a by diag(s) * a * diag(s). if( stdlib_lsame( uplo, 'U' ) ) then ! upper triangle of a is stored. do j = 1, n cj = s( j ) do i = 1, j - 1 a( i, j ) = cj*s( i )*a( i, j ) end do a( j, j ) = cj*cj*real( a( j, j ),KIND=${ck}$) end do else ! lower triangle of a is stored. do j = 1, n cj = s( j ) a( j, j ) = cj*cj*real( a( j, j ),KIND=${ck}$) do i = j + 1, n a( i, j ) = cj*s( i )*a( i, j ) end do end do end if equed = 'Y' end if return end subroutine stdlib${ii}$_${ci}$laqhe #:endif #:endfor real(sp) module function stdlib${ii}$_sla_porcond( uplo, n, a, lda, af, ldaf, cmode, c,info, work, iwork ) !! SLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C !! CMODE = 0 op2(C) = I !! CMODE = -1 op2(C) = inv(C) !! The Skeel condition number cond(A) = norminf( |inv(A)||A| ) !! is computed by computing scaling factors R such that !! diag(R)*A*op2(C) is row equilibrated and computing the standard !! infinity-norm condition number. ! -- 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) :: uplo integer(${ik}$), intent(in) :: n, lda, ldaf, cmode integer(${ik}$), intent(out) :: info real(sp), intent(in) :: a(lda,*), af(ldaf,*), c(*) real(sp), intent(out) :: work(*) ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: kase, i, j real(sp) :: ainvnm, tmp logical(lk) :: up ! Array Arguments integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements stdlib${ii}$_sla_porcond = zero info = 0_${ik}$ if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SLA_PORCOND', -info ) return end if if( n==0_${ik}$ ) then stdlib${ii}$_sla_porcond = one return end if up = .false. if ( stdlib_lsame( uplo, 'U' ) ) up = .true. ! compute the equilibration matrix r such that ! inv(r)*a*c has unit 1-norm. if ( up ) then do i = 1, n tmp = zero if ( cmode == 1_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( j, i ) * c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( i, j ) * c( j ) ) end do else if ( cmode == 0_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( j, i ) ) end do do j = i+1, n tmp = tmp + abs( a( i, j ) ) end do else do j = 1, i tmp = tmp + abs( a( j ,i ) / c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( i, j ) / c( j ) ) end do end if work( 2_${ik}$*n+i ) = tmp end do else do i = 1, n tmp = zero if ( cmode == 1_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( i, j ) * c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( j, i ) * c( j ) ) end do else if ( cmode == 0_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( i, j ) ) end do do j = i+1, n tmp = tmp + abs( a( j, i ) ) end do else do j = 1, i tmp = tmp + abs( a( i, j ) / c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( j, i ) / c( j ) ) end do end if work( 2_${ik}$*n+i ) = tmp end do endif ! estimate the norm of inv(op(a)). ainvnm = zero kase = 0_${ik}$ 10 continue call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( kase==2_${ik}$ ) then ! multiply by r. do i = 1, n work( i ) = work( i ) * work( 2_${ik}$*n+i ) end do if (up) then call stdlib${ii}$_spotrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info ) else call stdlib${ii}$_spotrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info ) endif ! multiply by inv(c). if ( cmode == 1_${ik}$ ) then do i = 1, n work( i ) = work( i ) / c( i ) end do else if ( cmode == -1_${ik}$ ) then do i = 1, n work( i ) = work( i ) * c( i ) end do end if else ! multiply by inv(c**t). if ( cmode == 1_${ik}$ ) then do i = 1, n work( i ) = work( i ) / c( i ) end do else if ( cmode == -1_${ik}$ ) then do i = 1, n work( i ) = work( i ) * c( i ) end do end if if ( up ) then call stdlib${ii}$_spotrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info ) else call stdlib${ii}$_spotrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info ) endif ! multiply by r. do i = 1, n work( i ) = work( i ) * work( 2_${ik}$*n+i ) end do end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm /= 0.0_sp )stdlib${ii}$_sla_porcond = ( one / ainvnm ) return end function stdlib${ii}$_sla_porcond real(dp) module function stdlib${ii}$_dla_porcond( uplo, n, a, lda, af, ldaf,cmode, c, info, work,iwork ) !! DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C !! CMODE = 0 op2(C) = I !! CMODE = -1 op2(C) = inv(C) !! The Skeel condition number cond(A) = norminf( |inv(A)||A| ) !! is computed by computing scaling factors R such that !! diag(R)*A*op2(C) is row equilibrated and computing the standard !! infinity-norm condition number. ! -- 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) :: uplo integer(${ik}$), intent(in) :: n, lda, ldaf, cmode integer(${ik}$), intent(out) :: info real(dp), intent(in) :: a(lda,*), af(ldaf,*), c(*) real(dp), intent(out) :: work(*) ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: kase, i, j real(dp) :: ainvnm, tmp logical(lk) :: up ! Array Arguments integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements stdlib${ii}$_dla_porcond = zero info = 0_${ik}$ if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DLA_PORCOND', -info ) return end if if( n==0_${ik}$ ) then stdlib${ii}$_dla_porcond = one return end if up = .false. if ( stdlib_lsame( uplo, 'U' ) ) up = .true. ! compute the equilibration matrix r such that ! inv(r)*a*c has unit 1-norm. if ( up ) then do i = 1, n tmp = zero if ( cmode == 1_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( j, i ) * c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( i, j ) * c( j ) ) end do else if ( cmode == 0_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( j, i ) ) end do do j = i+1, n tmp = tmp + abs( a( i, j ) ) end do else do j = 1, i tmp = tmp + abs( a( j ,i ) / c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( i, j ) / c( j ) ) end do end if work( 2_${ik}$*n+i ) = tmp end do else do i = 1, n tmp = zero if ( cmode == 1_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( i, j ) * c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( j, i ) * c( j ) ) end do else if ( cmode == 0_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( i, j ) ) end do do j = i+1, n tmp = tmp + abs( a( j, i ) ) end do else do j = 1, i tmp = tmp + abs( a( i, j ) / c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( j, i ) / c( j ) ) end do end if work( 2_${ik}$*n+i ) = tmp end do endif ! estimate the norm of inv(op(a)). ainvnm = zero kase = 0_${ik}$ 10 continue call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( kase==2_${ik}$ ) then ! multiply by r. do i = 1, n work( i ) = work( i ) * work( 2_${ik}$*n+i ) end do if (up) then call stdlib${ii}$_dpotrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info ) else call stdlib${ii}$_dpotrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info ) endif ! multiply by inv(c). if ( cmode == 1_${ik}$ ) then do i = 1, n work( i ) = work( i ) / c( i ) end do else if ( cmode == -1_${ik}$ ) then do i = 1, n work( i ) = work( i ) * c( i ) end do end if else ! multiply by inv(c**t). if ( cmode == 1_${ik}$ ) then do i = 1, n work( i ) = work( i ) / c( i ) end do else if ( cmode == -1_${ik}$ ) then do i = 1, n work( i ) = work( i ) * c( i ) end do end if if ( up ) then call stdlib${ii}$_dpotrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info ) else call stdlib${ii}$_dpotrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info ) endif ! multiply by r. do i = 1, n work( i ) = work( i ) * work( 2_${ik}$*n+i ) end do end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm /= zero )stdlib${ii}$_dla_porcond = ( one / ainvnm ) return end function stdlib${ii}$_dla_porcond #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] real(${rk}$) module function stdlib${ii}$_${ri}$la_porcond( uplo, n, a, lda, af, ldaf,cmode, c, info, work,iwork ) !! DLA_PORCOND: Estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C !! CMODE = 0 op2(C) = I !! CMODE = -1 op2(C) = inv(C) !! The Skeel condition number cond(A) = norminf( |inv(A)||A| ) !! is computed by computing scaling factors R such that !! diag(R)*A*op2(C) is row equilibrated and computing the standard !! infinity-norm condition number. ! -- 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) :: uplo integer(${ik}$), intent(in) :: n, lda, ldaf, cmode integer(${ik}$), intent(out) :: info real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), c(*) real(${rk}$), intent(out) :: work(*) ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: kase, i, j real(${rk}$) :: ainvnm, tmp logical(lk) :: up ! Array Arguments integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements stdlib${ii}$_${ri}$la_porcond = zero info = 0_${ik}$ if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DLA_PORCOND', -info ) return end if if( n==0_${ik}$ ) then stdlib${ii}$_${ri}$la_porcond = one return end if up = .false. if ( stdlib_lsame( uplo, 'U' ) ) up = .true. ! compute the equilibration matrix r such that ! inv(r)*a*c has unit 1-norm. if ( up ) then do i = 1, n tmp = zero if ( cmode == 1_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( j, i ) * c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( i, j ) * c( j ) ) end do else if ( cmode == 0_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( j, i ) ) end do do j = i+1, n tmp = tmp + abs( a( i, j ) ) end do else do j = 1, i tmp = tmp + abs( a( j ,i ) / c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( i, j ) / c( j ) ) end do end if work( 2_${ik}$*n+i ) = tmp end do else do i = 1, n tmp = zero if ( cmode == 1_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( i, j ) * c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( j, i ) * c( j ) ) end do else if ( cmode == 0_${ik}$ ) then do j = 1, i tmp = tmp + abs( a( i, j ) ) end do do j = i+1, n tmp = tmp + abs( a( j, i ) ) end do else do j = 1, i tmp = tmp + abs( a( i, j ) / c( j ) ) end do do j = i+1, n tmp = tmp + abs( a( j, i ) / c( j ) ) end do end if work( 2_${ik}$*n+i ) = tmp end do endif ! estimate the norm of inv(op(a)). ainvnm = zero kase = 0_${ik}$ 10 continue call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( kase==2_${ik}$ ) then ! multiply by r. do i = 1, n work( i ) = work( i ) * work( 2_${ik}$*n+i ) end do if (up) then call stdlib${ii}$_${ri}$potrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info ) else call stdlib${ii}$_${ri}$potrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info ) endif ! multiply by inv(c). if ( cmode == 1_${ik}$ ) then do i = 1, n work( i ) = work( i ) / c( i ) end do else if ( cmode == -1_${ik}$ ) then do i = 1, n work( i ) = work( i ) * c( i ) end do end if else ! multiply by inv(c**t). if ( cmode == 1_${ik}$ ) then do i = 1, n work( i ) = work( i ) / c( i ) end do else if ( cmode == -1_${ik}$ ) then do i = 1, n work( i ) = work( i ) * c( i ) end do end if if ( up ) then call stdlib${ii}$_${ri}$potrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info ) else call stdlib${ii}$_${ri}$potrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info ) endif ! multiply by r. do i = 1, n work( i ) = work( i ) * work( 2_${ik}$*n+i ) end do end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm /= zero )stdlib${ii}$_${ri}$la_porcond = ( one / ainvnm ) return end function stdlib${ii}$_${ri}$la_porcond #:endif #:endfor real(sp) module function stdlib${ii}$_sla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work ) !! SLA_PORPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. ! -- 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) :: uplo integer(${ik}$), intent(in) :: ncols, lda, ldaf ! Array Arguments real(sp), intent(in) :: a(lda,*), af(ldaf,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, j real(sp) :: amax, umax, rpvgrw logical(lk) :: upper ! Intrinsic Functions ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) ! stdlib${ii}$_spotrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one do i = 1, 2*ncols work( i ) = zero end do ! find the max magnitude entry of each column. if ( upper ) then do j = 1, ncols do i = 1, j work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) ) end do end do else do j = 1, ncols do i = j, ncols work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) ) end do end do end if ! now find the max magnitude entry of each column of the factor in ! af. no pivoting, so no permutations. if ( stdlib_lsame( 'UPPER', uplo ) ) then do j = 1, ncols do i = 1, j work( j ) = max( abs( af( i, j ) ), work( j ) ) end do end do else do j = 1, ncols do i = j, ncols work( j ) = max( abs( af( i, j ) ), work( j ) ) end do end do end if ! compute the *inverse* of the max element growth factor. dividing ! by zero would imply the largest entry of the factor's column is ! zero. than can happen when either the column of a is zero or ! massive pivots made the factor underflow to zero. neither counts ! as growth in itself, so simply ignore terms with zero ! denominators. if ( stdlib_lsame( 'UPPER', uplo ) ) then do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= 0.0_sp ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do else do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= 0.0_sp ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do end if stdlib${ii}$_sla_porpvgrw = rpvgrw end function stdlib${ii}$_sla_porpvgrw real(dp) module function stdlib${ii}$_dla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) !! DLA_PORPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. ! -- 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) :: uplo integer(${ik}$), intent(in) :: ncols, lda, ldaf ! Array Arguments real(dp), intent(in) :: a(lda,*), af(ldaf,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, j real(dp) :: amax, umax, rpvgrw logical(lk) :: upper ! Intrinsic Functions ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) ! stdlib${ii}$_dpotrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one do i = 1, 2*ncols work( i ) = zero end do ! find the max magnitude entry of each column. if ( upper ) then do j = 1, ncols do i = 1, j work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) ) end do end do else do j = 1, ncols do i = j, ncols work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) ) end do end do end if ! now find the max magnitude entry of each column of the factor in ! af. no pivoting, so no permutations. if ( stdlib_lsame( 'UPPER', uplo ) ) then do j = 1, ncols do i = 1, j work( j ) = max( abs( af( i, j ) ), work( j ) ) end do end do else do j = 1, ncols do i = j, ncols work( j ) = max( abs( af( i, j ) ), work( j ) ) end do end do end if ! compute the *inverse* of the max element growth factor. dividing ! by zero would imply the largest entry of the factor's column is ! zero. than can happen when either the column of a is zero or ! massive pivots made the factor underflow to zero. neither counts ! as growth in itself, so simply ignore terms with zero ! denominators. if ( stdlib_lsame( 'UPPER', uplo ) ) then do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= zero ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do else do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= zero ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do end if stdlib${ii}$_dla_porpvgrw = rpvgrw end function stdlib${ii}$_dla_porpvgrw #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] real(${rk}$) module function stdlib${ii}$_${ri}$la_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) !! DLA_PORPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. ! -- 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) :: uplo integer(${ik}$), intent(in) :: ncols, lda, ldaf ! Array Arguments real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, j real(${rk}$) :: amax, umax, rpvgrw logical(lk) :: upper ! Intrinsic Functions ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) ! stdlib${ii}$_${ri}$potrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one do i = 1, 2*ncols work( i ) = zero end do ! find the max magnitude entry of each column. if ( upper ) then do j = 1, ncols do i = 1, j work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) ) end do end do else do j = 1, ncols do i = j, ncols work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) ) end do end do end if ! now find the max magnitude entry of each column of the factor in ! af. no pivoting, so no permutations. if ( stdlib_lsame( 'UPPER', uplo ) ) then do j = 1, ncols do i = 1, j work( j ) = max( abs( af( i, j ) ), work( j ) ) end do end do else do j = 1, ncols do i = j, ncols work( j ) = max( abs( af( i, j ) ), work( j ) ) end do end do end if ! compute the *inverse* of the max element growth factor. dividing ! by zero would imply the largest entry of the factor's column is ! zero. than can happen when either the column of a is zero or ! massive pivots made the factor underflow to zero. neither counts ! as growth in itself, so simply ignore terms with zero ! denominators. if ( stdlib_lsame( 'UPPER', uplo ) ) then do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= zero ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do else do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= zero ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do end if stdlib${ii}$_${ri}$la_porpvgrw = rpvgrw end function stdlib${ii}$_${ri}$la_porpvgrw #:endif #:endfor real(sp) module function stdlib${ii}$_cla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work ) !! CLA_PORPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. ! -- 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) :: uplo integer(${ik}$), intent(in) :: ncols, lda, ldaf ! Array Arguments complex(sp), intent(in) :: a(lda,*), af(ldaf,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, j real(sp) :: amax, umax, rpvgrw logical(lk) :: upper complex(sp) :: zdum ! Intrinsic Functions ! Statement Functions real(sp) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) ! stdlib${ii}$_spotrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one do i = 1, 2*ncols work( i ) = zero end do ! find the max magnitude entry of each column. if ( upper ) then do j = 1, ncols do i = 1, j work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) ) end do end do else do j = 1, ncols do i = j, ncols work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) ) end do end do end if ! now find the max magnitude entry of each column of the factor in ! af. no pivoting, so no permutations. if ( stdlib_lsame( 'UPPER', uplo ) ) then do j = 1, ncols do i = 1, j work( j ) = max( cabs1( af( i, j ) ), work( j ) ) end do end do else do j = 1, ncols do i = j, ncols work( j ) = max( cabs1( af( i, j ) ), work( j ) ) end do end do end if ! compute the *inverse* of the max element growth factor. dividing ! by zero would imply the largest entry of the factor's column is ! zero. than can happen when either the column of a is zero or ! massive pivots made the factor underflow to zero. neither counts ! as growth in itself, so simply ignore terms with zero ! denominators. if ( stdlib_lsame( 'UPPER', uplo ) ) then do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= 0.0_sp ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do else do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= 0.0_sp ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do end if stdlib${ii}$_cla_porpvgrw = rpvgrw end function stdlib${ii}$_cla_porpvgrw real(dp) module function stdlib${ii}$_zla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) !! ZLA_PORPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. ! -- 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) :: uplo integer(${ik}$), intent(in) :: ncols, lda, ldaf ! Array Arguments complex(dp), intent(in) :: a(lda,*), af(ldaf,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, j real(dp) :: amax, umax, rpvgrw logical(lk) :: upper complex(dp) :: zdum ! Intrinsic Functions ! Statement Functions real(dp) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) ! stdlib${ii}$_dpotrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one do i = 1, 2*ncols work( i ) = zero end do ! find the max magnitude entry of each column. if ( upper ) then do j = 1, ncols do i = 1, j work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) ) end do end do else do j = 1, ncols do i = j, ncols work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) ) end do end do end if ! now find the max magnitude entry of each column of the factor in ! af. no pivoting, so no permutations. if ( stdlib_lsame( 'UPPER', uplo ) ) then do j = 1, ncols do i = 1, j work( j ) = max( cabs1( af( i, j ) ), work( j ) ) end do end do else do j = 1, ncols do i = j, ncols work( j ) = max( cabs1( af( i, j ) ), work( j ) ) end do end do end if ! compute the *inverse* of the max element growth factor. dividing ! by zero would imply the largest entry of the factor's column is ! zero. than can happen when either the column of a is zero or ! massive pivots made the factor underflow to zero. neither counts ! as growth in itself, so simply ignore terms with zero ! denominators. if ( stdlib_lsame( 'UPPER', uplo ) ) then do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= zero ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do else do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= zero ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do end if stdlib${ii}$_zla_porpvgrw = rpvgrw end function stdlib${ii}$_zla_porpvgrw #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] real(${ck}$) module function stdlib${ii}$_${ci}$la_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) !! ZLA_PORPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. ! -- 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) :: uplo integer(${ik}$), intent(in) :: ncols, lda, ldaf ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) real(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(${ik}$) :: i, j real(${ck}$) :: amax, umax, rpvgrw logical(lk) :: upper complex(${ck}$) :: zdum ! Intrinsic Functions ! Statement Functions real(${ck}$) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) ! stdlib${ii}$_${ci}$otrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one do i = 1, 2*ncols work( i ) = zero end do ! find the max magnitude entry of each column. if ( upper ) then do j = 1, ncols do i = 1, j work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) ) end do end do else do j = 1, ncols do i = j, ncols work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) ) end do end do end if ! now find the max magnitude entry of each column of the factor in ! af. no pivoting, so no permutations. if ( stdlib_lsame( 'UPPER', uplo ) ) then do j = 1, ncols do i = 1, j work( j ) = max( cabs1( af( i, j ) ), work( j ) ) end do end do else do j = 1, ncols do i = j, ncols work( j ) = max( cabs1( af( i, j ) ), work( j ) ) end do end do end if ! compute the *inverse* of the max element growth factor. dividing ! by zero would imply the largest entry of the factor's column is ! zero. than can happen when either the column of a is zero or ! massive pivots made the factor underflow to zero. neither counts ! as growth in itself, so simply ignore terms with zero ! denominators. if ( stdlib_lsame( 'UPPER', uplo ) ) then do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= zero ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do else do i = 1, ncols umax = work( i ) amax = work( ncols+i ) if ( umax /= zero ) then rpvgrw = min( amax / umax, rpvgrw ) end if end do end if stdlib${ii}$_${ci}$la_porpvgrw = rpvgrw end function stdlib${ii}$_${ci}$la_porpvgrw #:endif #:endfor pure module subroutine stdlib${ii}$_sppcon( uplo, n, ap, anorm, rcond, work, iwork, info ) !! SPPCON estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric positive definite packed matrix using !! the Cholesky factorization A = U**T*U or A = L*L**T computed by !! SPPTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(in) :: ap(*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(sp) :: ainvnm, scale, scalel, scaleu, smlnum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( anorm<zero ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPPCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of the inverse. kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**t). call stdlib${ii}$_slatps( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scalel,& work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_slatps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scaleu, work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(l). call stdlib${ii}$_slatps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scalel, work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(l**t). call stdlib${ii}$_slatps( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scaleu,& work( 2_${ik}$*n+1 ), info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ ) if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_srscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_sppcon pure module subroutine stdlib${ii}$_dppcon( uplo, n, ap, anorm, rcond, work, iwork, info ) !! DPPCON estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric positive definite packed matrix using !! the Cholesky factorization A = U**T*U or A = L*L**T computed by !! DPPTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(in) :: ap(*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(dp) :: ainvnm, scale, scalel, scaleu, smlnum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( anorm<zero ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of the inverse. kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**t). call stdlib${ii}$_dlatps( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scalel,& work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_dlatps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scaleu, work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(l). call stdlib${ii}$_dlatps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scalel, work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(l**t). call stdlib${ii}$_dlatps( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scaleu,& work( 2_${ik}$*n+1 ), info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ ) if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_drscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_dppcon #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$ppcon( uplo, n, ap, anorm, rcond, work, iwork, info ) !! DPPCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric positive definite packed matrix using !! the Cholesky factorization A = U**T*U or A = L*L**T computed by !! DPPTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(${rk}$), intent(in) :: anorm real(${rk}$), intent(out) :: rcond ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(in) :: ap(*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(${rk}$) :: ainvnm, scale, scalel, scaleu, smlnum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( anorm<zero ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of the inverse. kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**t). call stdlib${ii}$_${ri}$latps( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scalel,& work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_${ri}$latps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scaleu, work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(l). call stdlib${ii}$_${ri}$latps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scalel, work( 2_${ik}$*n+1 ), info ) normin = 'Y' ! multiply by inv(l**t). call stdlib${ii}$_${ri}$latps( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scaleu,& work( 2_${ik}$*n+1 ), info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ ) if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_${ri}$rscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_${ri}$ppcon #:endif #:endfor pure module subroutine stdlib${ii}$_cppcon( uplo, n, ap, anorm, rcond, work, rwork, info ) !! CPPCON estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite packed matrix using !! the Cholesky factorization A = U**H*U or A = L*L**H computed by !! CPPTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments real(sp), intent(out) :: rwork(*) complex(sp), intent(in) :: ap(*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(sp) :: ainvnm, scale, scalel, scaleu, smlnum complex(sp) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(sp) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( anorm<zero ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPPCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of the inverse. kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**h). call stdlib${ii}$_clatps( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, & work, scalel, rwork, info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_clatps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scaleu, rwork, info ) else ! multiply by inv(l). call stdlib${ii}$_clatps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scalel, rwork, info ) normin = 'Y' ! multiply by inv(l**h). call stdlib${ii}$_clatps( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, & work, scaleu, rwork, info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ ) if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_csrscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_cppcon pure module subroutine stdlib${ii}$_zppcon( uplo, n, ap, anorm, rcond, work, rwork, info ) !! ZPPCON estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite packed matrix using !! the Cholesky factorization A = U**H*U or A = L*L**H computed by !! ZPPTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond ! Array Arguments real(dp), intent(out) :: rwork(*) complex(dp), intent(in) :: ap(*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(dp) :: ainvnm, scale, scalel, scaleu, smlnum complex(dp) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(dp) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( anorm<zero ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of the inverse. kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**h). call stdlib${ii}$_zlatps( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, & work, scalel, rwork, info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_zlatps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scaleu, rwork, info ) else ! multiply by inv(l). call stdlib${ii}$_zlatps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scalel, rwork, info ) normin = 'Y' ! multiply by inv(l**h). call stdlib${ii}$_zlatps( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, & work, scaleu, rwork, info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ ) if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_zdrscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_zppcon #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$ppcon( uplo, n, ap, anorm, rcond, work, rwork, info ) !! ZPPCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite packed matrix using !! the Cholesky factorization A = U**H*U or A = L*L**H computed by !! ZPPTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(${ck}$), intent(in) :: anorm real(${ck}$), intent(out) :: rcond ! Array Arguments real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(in) :: ap(*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(${ck}$) :: ainvnm, scale, scalel, scaleu, smlnum complex(${ck}$) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(${ck}$) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( anorm<zero ) then info = -4_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPCON', -info ) return end if ! quick return if possible rcond = zero if( n==0_${ik}$ ) then rcond = one return else if( anorm==zero ) then return end if smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of the inverse. kase = 0_${ik}$ normin = 'N' 10 continue call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0_${ik}$ ) then if( upper ) then ! multiply by inv(u**h). call stdlib${ii}$_${ci}$latps( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, & work, scalel, rwork, info ) normin = 'Y' ! multiply by inv(u). call stdlib${ii}$_${ci}$latps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scaleu, rwork, info ) else ! multiply by inv(l). call stdlib${ii}$_${ci}$latps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scalel, rwork, info ) normin = 'Y' ! multiply by inv(l**h). call stdlib${ii}$_${ci}$latps( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, & work, scaleu, rwork, info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ ) if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20 call stdlib${ii}$_${ci}$drscl( n, scale, work, 1_${ik}$ ) end if go to 10 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm 20 continue return end subroutine stdlib${ii}$_${ci}$ppcon #:endif #:endfor pure module subroutine stdlib${ii}$_spptrf( uplo, n, ap, info ) !! SPPTRF computes the Cholesky factorization of a real symmetric !! positive definite matrix A stored in packed format. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments real(sp), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj real(sp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPPTRF', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**t*u. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j ! compute elements 1:j-1 of column j. if( j>1_${ik}$ )call stdlib${ii}$_stpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), & 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. ajj = ap( jj ) - stdlib${ii}$_sdot( j-1, ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ ) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ap( jj ) = sqrt( ajj ) end do else ! compute the cholesky factorization a = l*l**t. jj = 1_${ik}$ do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = ap( jj ) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ajj = sqrt( ajj ) ap( jj ) = ajj ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j<n ) then call stdlib${ii}$_sscal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ ) call stdlib${ii}$_sspr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) ) jj = jj + n - j + 1_${ik}$ end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_spptrf pure module subroutine stdlib${ii}$_dpptrf( uplo, n, ap, info ) !! DPPTRF computes the Cholesky factorization of a real symmetric !! positive definite matrix A stored in packed format. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments real(dp), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj real(dp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPTRF', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**t*u. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j ! compute elements 1:j-1 of column j. if( j>1_${ik}$ )call stdlib${ii}$_dtpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), & 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. ajj = ap( jj ) - stdlib${ii}$_ddot( j-1, ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ ) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ap( jj ) = sqrt( ajj ) end do else ! compute the cholesky factorization a = l*l**t. jj = 1_${ik}$ do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = ap( jj ) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ajj = sqrt( ajj ) ap( jj ) = ajj ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j<n ) then call stdlib${ii}$_dscal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ ) call stdlib${ii}$_dspr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) ) jj = jj + n - j + 1_${ik}$ end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_dpptrf #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$pptrf( uplo, n, ap, info ) !! DPPTRF: computes the Cholesky factorization of a real symmetric !! positive definite matrix A stored in packed format. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments real(${rk}$), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj real(${rk}$) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPTRF', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**t*u. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j ! compute elements 1:j-1 of column j. if( j>1_${ik}$ )call stdlib${ii}$_${ri}$tpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), & 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. ajj = ap( jj ) - stdlib${ii}$_${ri}$dot( j-1, ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ ) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ap( jj ) = sqrt( ajj ) end do else ! compute the cholesky factorization a = l*l**t. jj = 1_${ik}$ do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = ap( jj ) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ajj = sqrt( ajj ) ap( jj ) = ajj ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j<n ) then call stdlib${ii}$_${ri}$scal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ ) call stdlib${ii}$_${ri}$spr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) ) jj = jj + n - j + 1_${ik}$ end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_${ri}$pptrf #:endif #:endfor pure module subroutine stdlib${ii}$_cpptrf( uplo, n, ap, info ) !! CPPTRF computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A stored in packed format. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments complex(sp), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj real(sp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPPTRF', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**h * u. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j ! compute elements 1:j-1 of column j. if( j>1_${ik}$ )call stdlib${ii}$_ctpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & ap( jc ), 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. ajj = real( real( ap( jj ),KIND=sp) - stdlib${ii}$_cdotc( j-1,ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ & ),KIND=sp) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ap( jj ) = sqrt( ajj ) end do else ! compute the cholesky factorization a = l * l**h. jj = 1_${ik}$ do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = real( ap( jj ),KIND=sp) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ajj = sqrt( ajj ) ap( jj ) = ajj ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j<n ) then call stdlib${ii}$_csscal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ ) call stdlib${ii}$_chpr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) ) jj = jj + n - j + 1_${ik}$ end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_cpptrf pure module subroutine stdlib${ii}$_zpptrf( uplo, n, ap, info ) !! ZPPTRF computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A stored in packed format. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments complex(dp), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj real(dp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPTRF', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**h * u. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j ! compute elements 1:j-1 of column j. if( j>1_${ik}$ )call stdlib${ii}$_ztpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & ap( jc ), 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. ajj = real( ap( jj ),KIND=dp) - real( stdlib${ii}$_zdotc( j-1,ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ & ),KIND=dp) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ap( jj ) = sqrt( ajj ) end do else ! compute the cholesky factorization a = l * l**h. jj = 1_${ik}$ do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = real( ap( jj ),KIND=dp) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ajj = sqrt( ajj ) ap( jj ) = ajj ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j<n ) then call stdlib${ii}$_zdscal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ ) call stdlib${ii}$_zhpr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) ) jj = jj + n - j + 1_${ik}$ end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_zpptrf #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$pptrf( uplo, n, ap, info ) !! ZPPTRF: computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A stored in packed format. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments complex(${ck}$), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj real(${ck}$) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPTRF', -info ) return end if ! quick return if possible if( n==0 )return if( upper ) then ! compute the cholesky factorization a = u**h * u. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j ! compute elements 1:j-1 of column j. if( j>1_${ik}$ )call stdlib${ii}$_${ci}$tpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & ap( jc ), 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. ajj = real( ap( jj ),KIND=${ck}$) - real( stdlib${ii}$_${ci}$dotc( j-1,ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ & ),KIND=${ck}$) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ap( jj ) = sqrt( ajj ) end do else ! compute the cholesky factorization a = l * l**h. jj = 1_${ik}$ do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = real( ap( jj ),KIND=${ck}$) if( ajj<=zero ) then ap( jj ) = ajj go to 30 end if ajj = sqrt( ajj ) ap( jj ) = ajj ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j<n ) then call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ ) call stdlib${ii}$_${ci}$hpr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) ) jj = jj + n - j + 1_${ik}$ end if end do end if go to 40 30 continue info = j 40 continue return end subroutine stdlib${ii}$_${ci}$pptrf #:endif #:endfor pure module subroutine stdlib${ii}$_spptrs( uplo, n, nrhs, ap, b, ldb, info ) !! SPPTRS solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A in packed storage using the Cholesky !! factorization A = U**T*U or A = L*L**T computed by SPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(sp), intent(in) :: ap(*) real(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPPTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**t * u. do i = 1, nrhs ! solve u**t *x = b, overwriting b with x. call stdlib${ii}$_stpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_stpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) end do else ! solve a*x = b where a = l * l**t. do i = 1, nrhs ! solve l*y = b, overwriting b with x. call stdlib${ii}$_stpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) ! solve l**t *x = y, overwriting b with x. call stdlib${ii}$_stpsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) end do end if return end subroutine stdlib${ii}$_spptrs pure module subroutine stdlib${ii}$_dpptrs( uplo, n, nrhs, ap, b, ldb, info ) !! DPPTRS solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A in packed storage using the Cholesky !! factorization A = U**T*U or A = L*L**T computed by DPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(dp), intent(in) :: ap(*) real(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**t * u. do i = 1, nrhs ! solve u**t *x = b, overwriting b with x. call stdlib${ii}$_dtpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_dtpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) end do else ! solve a*x = b where a = l * l**t. do i = 1, nrhs ! solve l*y = b, overwriting b with x. call stdlib${ii}$_dtpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) ! solve l**t *x = y, overwriting b with x. call stdlib${ii}$_dtpsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) end do end if return end subroutine stdlib${ii}$_dpptrs #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$pptrs( uplo, n, nrhs, ap, b, ldb, info ) !! DPPTRS: solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A in packed storage using the Cholesky !! factorization A = U**T*U or A = L*L**T computed by DPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(${rk}$), intent(in) :: ap(*) real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**t * u. do i = 1, nrhs ! solve u**t *x = b, overwriting b with x. call stdlib${ii}$_${ri}$tpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_${ri}$tpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) end do else ! solve a*x = b where a = l * l**t. do i = 1, nrhs ! solve l*y = b, overwriting b with x. call stdlib${ii}$_${ri}$tpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) ! solve l**t *x = y, overwriting b with x. call stdlib${ii}$_${ri}$tpsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) end do end if return end subroutine stdlib${ii}$_${ri}$pptrs #:endif #:endfor pure module subroutine stdlib${ii}$_cpptrs( uplo, n, nrhs, ap, b, ldb, info ) !! CPPTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A in packed storage using the Cholesky !! factorization A = U**H*U or A = L*L**H computed by CPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments complex(sp), intent(in) :: ap(*) complex(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPPTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**h * u. do i = 1, nrhs ! solve u**h *x = b, overwriting b with x. call stdlib${ii}$_ctpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), & 1_${ik}$ ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_ctpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) end do else ! solve a*x = b where a = l * l**h. do i = 1, nrhs ! solve l*y = b, overwriting b with x. call stdlib${ii}$_ctpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) ! solve l**h *x = y, overwriting b with x. call stdlib${ii}$_ctpsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), & 1_${ik}$ ) end do end if return end subroutine stdlib${ii}$_cpptrs pure module subroutine stdlib${ii}$_zpptrs( uplo, n, nrhs, ap, b, ldb, info ) !! ZPPTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A in packed storage using the Cholesky !! factorization A = U**H * U or A = L * L**H computed by ZPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments complex(dp), intent(in) :: ap(*) complex(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**h * u. do i = 1, nrhs ! solve u**h *x = b, overwriting b with x. call stdlib${ii}$_ztpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), & 1_${ik}$ ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_ztpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) end do else ! solve a*x = b where a = l * l**h. do i = 1, nrhs ! solve l*y = b, overwriting b with x. call stdlib${ii}$_ztpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) ! solve l**h *x = y, overwriting b with x. call stdlib${ii}$_ztpsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), & 1_${ik}$ ) end do end if return end subroutine stdlib${ii}$_zpptrs #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$pptrs( uplo, n, nrhs, ap, b, ldb, info ) !! ZPPTRS: solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A in packed storage using the Cholesky !! factorization A = U**H * U or A = L * L**H computed by ZPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments complex(${ck}$), intent(in) :: ap(*) complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -6_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return if( upper ) then ! solve a*x = b where a = u**h * u. do i = 1, nrhs ! solve u**h *x = b, overwriting b with x. call stdlib${ii}$_${ci}$tpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), & 1_${ik}$ ) ! solve u*x = b, overwriting b with x. call stdlib${ii}$_${ci}$tpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) end do else ! solve a*x = b where a = l * l**h. do i = 1, nrhs ! solve l*y = b, overwriting b with x. call stdlib${ii}$_${ci}$tpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ ) ! solve l**h *x = y, overwriting b with x. call stdlib${ii}$_${ci}$tpsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), & 1_${ik}$ ) end do end if return end subroutine stdlib${ii}$_${ci}$pptrs #:endif #:endfor pure module subroutine stdlib${ii}$_spptri( uplo, n, ap, info ) !! SPPTRI computes the inverse of a real symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by SPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments real(sp), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj, jjn real(sp) :: ajj ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPPTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_stptri( uplo, 'NON-UNIT', n, ap, info ) if( info>0 )return if( upper ) then ! compute the product inv(u) * inv(u)**t. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j if( j>1_${ik}$ )call stdlib${ii}$_sspr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap ) ajj = ap( jj ) call stdlib${ii}$_sscal( j, ajj, ap( jc ), 1_${ik}$ ) end do else ! compute the product inv(l)**t * inv(l). jj = 1_${ik}$ do j = 1, n jjn = jj + n - j + 1_${ik}$ ap( jj ) = stdlib${ii}$_sdot( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ ) if( j<n )call stdlib${ii}$_stpmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n-j,ap( jjn ), ap( & jj+1 ), 1_${ik}$ ) jj = jjn end do end if return end subroutine stdlib${ii}$_spptri pure module subroutine stdlib${ii}$_dpptri( uplo, n, ap, info ) !! DPPTRI computes the inverse of a real symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by DPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments real(dp), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj, jjn real(dp) :: ajj ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_dtptri( uplo, 'NON-UNIT', n, ap, info ) if( info>0 )return if( upper ) then ! compute the product inv(u) * inv(u)**t. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j if( j>1_${ik}$ )call stdlib${ii}$_dspr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap ) ajj = ap( jj ) call stdlib${ii}$_dscal( j, ajj, ap( jc ), 1_${ik}$ ) end do else ! compute the product inv(l)**t * inv(l). jj = 1_${ik}$ do j = 1, n jjn = jj + n - j + 1_${ik}$ ap( jj ) = stdlib${ii}$_ddot( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ ) if( j<n )call stdlib${ii}$_dtpmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n-j,ap( jjn ), ap( & jj+1 ), 1_${ik}$ ) jj = jjn end do end if return end subroutine stdlib${ii}$_dpptri #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$pptri( uplo, n, ap, info ) !! DPPTRI: computes the inverse of a real symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by DPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments real(${rk}$), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj, jjn real(${rk}$) :: ajj ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_${ri}$tptri( uplo, 'NON-UNIT', n, ap, info ) if( info>0 )return if( upper ) then ! compute the product inv(u) * inv(u)**t. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j if( j>1_${ik}$ )call stdlib${ii}$_${ri}$spr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap ) ajj = ap( jj ) call stdlib${ii}$_${ri}$scal( j, ajj, ap( jc ), 1_${ik}$ ) end do else ! compute the product inv(l)**t * inv(l). jj = 1_${ik}$ do j = 1, n jjn = jj + n - j + 1_${ik}$ ap( jj ) = stdlib${ii}$_${ri}$dot( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ ) if( j<n )call stdlib${ii}$_${ri}$tpmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n-j,ap( jjn ), ap( & jj+1 ), 1_${ik}$ ) jj = jjn end do end if return end subroutine stdlib${ii}$_${ri}$pptri #:endif #:endfor pure module subroutine stdlib${ii}$_cpptri( uplo, n, ap, info ) !! CPPTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by CPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments complex(sp), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj, jjn real(sp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPPTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_ctptri( uplo, 'NON-UNIT', n, ap, info ) if( info>0 )return if( upper ) then ! compute the product inv(u) * inv(u)**h. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j if( j>1_${ik}$ )call stdlib${ii}$_chpr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap ) ajj = real( ap( jj ),KIND=sp) call stdlib${ii}$_csscal( j, ajj, ap( jc ), 1_${ik}$ ) end do else ! compute the product inv(l)**h * inv(l). jj = 1_${ik}$ do j = 1, n jjn = jj + n - j + 1_${ik}$ ap( jj ) = real( stdlib${ii}$_cdotc( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ ),KIND=sp) if( j<n )call stdlib${ii}$_ctpmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n-j, ap( & jjn ), ap( jj+1 ), 1_${ik}$ ) jj = jjn end do end if return end subroutine stdlib${ii}$_cpptri pure module subroutine stdlib${ii}$_zpptri( uplo, n, ap, info ) !! ZPPTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments complex(dp), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj, jjn real(dp) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_ztptri( uplo, 'NON-UNIT', n, ap, info ) if( info>0 )return if( upper ) then ! compute the product inv(u) * inv(u)**h. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j if( j>1_${ik}$ )call stdlib${ii}$_zhpr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap ) ajj = real( ap( jj ),KIND=dp) call stdlib${ii}$_zdscal( j, ajj, ap( jc ), 1_${ik}$ ) end do else ! compute the product inv(l)**h * inv(l). jj = 1_${ik}$ do j = 1, n jjn = jj + n - j + 1_${ik}$ ap( jj ) = real( stdlib${ii}$_zdotc( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ ),KIND=dp) if( j<n )call stdlib${ii}$_ztpmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n-j, ap( & jjn ), ap( jj+1 ), 1_${ik}$ ) jj = jjn end do end if return end subroutine stdlib${ii}$_zpptri #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$pptri( uplo, n, ap, info ) !! ZPPTRI: computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPPTRF. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments complex(${ck}$), intent(inout) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: j, jc, jj, jjn real(${ck}$) :: ajj ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_${ci}$tptri( uplo, 'NON-UNIT', n, ap, info ) if( info>0 )return if( upper ) then ! compute the product inv(u) * inv(u)**h. jj = 0_${ik}$ do j = 1, n jc = jj + 1_${ik}$ jj = jj + j if( j>1_${ik}$ )call stdlib${ii}$_${ci}$hpr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap ) ajj = real( ap( jj ),KIND=${ck}$) call stdlib${ii}$_${ci}$dscal( j, ajj, ap( jc ), 1_${ik}$ ) end do else ! compute the product inv(l)**h * inv(l). jj = 1_${ik}$ do j = 1, n jjn = jj + n - j + 1_${ik}$ ap( jj ) = real( stdlib${ii}$_${ci}$dotc( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ ),KIND=${ck}$) if( j<n )call stdlib${ii}$_${ci}$tpmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n-j, ap( & jjn ), ap( jj+1 ), 1_${ik}$ ) jj = jjn end do end if return end subroutine stdlib${ii}$_${ci}$pptri #:endif #:endfor pure module subroutine stdlib${ii}$_spprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & !! SPPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric positive definite !! and packed, and provides error bounds and backward error estimates !! for the solution. iwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(in) :: afp(*), ap(*), b(ldb,*) real(sp), intent(out) :: berr(*), ferr(*), work(*) real(sp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -9_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPPRFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_slamch( 'EPSILON' ) safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_scopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ ) call stdlib${ii}$_sspmv( uplo, n, -one, ap, x( 1_${ik}$, j ), 1_${ik}$, one, work( n+1 ),1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n work( i ) = abs( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). kk = 1_${ik}$ if( upper ) then do k = 1, n s = zero xk = abs( x( k, j ) ) ik = kk do i = 1, k - 1 work( i ) = work( i ) + abs( ap( ik ) )*xk s = s + abs( ap( ik ) )*abs( x( i, j ) ) ik = ik + 1_${ik}$ end do work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s kk = kk + k end do else do k = 1, n s = zero xk = abs( x( k, j ) ) work( k ) = work( k ) + abs( ap( kk ) )*xk ik = kk + 1_${ik}$ do i = k + 1, n work( i ) = work( i ) + abs( ap( ik ) )*xk s = s + abs( ap( ik ) )*abs( x( i, j ) ) ik = ik + 1_${ik}$ end do work( k ) = work( k ) + s kk = kk + ( n-k+1 ) end do end if s = zero do i = 1, n if( work( i )>safe2 ) then s = max( s, abs( work( n+i ) ) / work( i ) ) else s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_spptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info ) call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_slacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( work( i )>safe2 ) then work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) else work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_slacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). call stdlib${ii}$_spptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( n+i ) = work( i )*work( n+i ) end do call stdlib${ii}$_spptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, abs( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_spprfs pure module subroutine stdlib${ii}$_dpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & !! DPPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric positive definite !! and packed, and provides error bounds and backward error estimates !! for the solution. iwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(in) :: afp(*), ap(*), b(ldb,*) real(dp), intent(out) :: berr(*), ferr(*), work(*) real(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -9_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPRFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_dlamch( 'EPSILON' ) safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_dcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ ) call stdlib${ii}$_dspmv( uplo, n, -one, ap, x( 1_${ik}$, j ), 1_${ik}$, one, work( n+1 ),1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n work( i ) = abs( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). kk = 1_${ik}$ if( upper ) then do k = 1, n s = zero xk = abs( x( k, j ) ) ik = kk do i = 1, k - 1 work( i ) = work( i ) + abs( ap( ik ) )*xk s = s + abs( ap( ik ) )*abs( x( i, j ) ) ik = ik + 1_${ik}$ end do work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s kk = kk + k end do else do k = 1, n s = zero xk = abs( x( k, j ) ) work( k ) = work( k ) + abs( ap( kk ) )*xk ik = kk + 1_${ik}$ do i = k + 1, n work( i ) = work( i ) + abs( ap( ik ) )*xk s = s + abs( ap( ik ) )*abs( x( i, j ) ) ik = ik + 1_${ik}$ end do work( k ) = work( k ) + s kk = kk + ( n-k+1 ) end do end if s = zero do i = 1, n if( work( i )>safe2 ) then s = max( s, abs( work( n+i ) ) / work( i ) ) else s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_dpptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info ) call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_dlacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( work( i )>safe2 ) then work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) else work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_dlacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). call stdlib${ii}$_dpptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( n+i ) = work( i )*work( n+i ) end do call stdlib${ii}$_dpptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, abs( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_dpprfs #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$pprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & !! DPPRFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric positive definite !! and packed, and provides error bounds and backward error estimates !! for the solution. iwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(in) :: afp(*), ap(*), b(ldb,*) real(${rk}$), intent(out) :: berr(*), ferr(*), work(*) real(${rk}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -9_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPRFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' ) safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_${ri}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ ) call stdlib${ii}$_${ri}$spmv( uplo, n, -one, ap, x( 1_${ik}$, j ), 1_${ik}$, one, work( n+1 ),1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n work( i ) = abs( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). kk = 1_${ik}$ if( upper ) then do k = 1, n s = zero xk = abs( x( k, j ) ) ik = kk do i = 1, k - 1 work( i ) = work( i ) + abs( ap( ik ) )*xk s = s + abs( ap( ik ) )*abs( x( i, j ) ) ik = ik + 1_${ik}$ end do work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s kk = kk + k end do else do k = 1, n s = zero xk = abs( x( k, j ) ) work( k ) = work( k ) + abs( ap( kk ) )*xk ik = kk + 1_${ik}$ do i = k + 1, n work( i ) = work( i ) + abs( ap( ik ) )*xk s = s + abs( ap( ik ) )*abs( x( i, j ) ) ik = ik + 1_${ik}$ end do work( k ) = work( k ) + s kk = kk + ( n-k+1 ) end do end if s = zero do i = 1, n if( work( i )>safe2 ) then s = max( s, abs( work( n+i ) ) / work( i ) ) else s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_${ri}$pptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info ) call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( work( i )>safe2 ) then work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) else work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_${ri}$lacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). call stdlib${ii}$_${ri}$pptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( n+i ) = work( i )*work( n+i ) end do call stdlib${ii}$_${ri}$pptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, abs( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_${ri}$pprfs #:endif #:endfor pure module subroutine stdlib${ii}$_cpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & !! CPPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite !! and packed, and provides error bounds and backward error estimates !! for the solution. rwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments real(sp), intent(out) :: berr(*), ferr(*), rwork(*) complex(sp), intent(in) :: afp(*), ap(*), b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) ! ==================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(sp) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(sp) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -9_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPPRFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_slamch( 'EPSILON' ) safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_ccopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ ) call stdlib${ii}$_chpmv( uplo, n, -cone, ap, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n rwork( i ) = cabs1( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). kk = 1_${ik}$ if( upper ) then do k = 1, n s = zero xk = cabs1( x( k, j ) ) ik = kk do i = 1, k - 1 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) ) ik = ik + 1_${ik}$ end do rwork( k ) = rwork( k ) + abs( real( ap( kk+k-1 ),KIND=sp) )*xk + s kk = kk + k end do else do k = 1, n s = zero xk = cabs1( x( k, j ) ) rwork( k ) = rwork( k ) + abs( real( ap( kk ),KIND=sp) )*xk ik = kk + 1_${ik}$ do i = k + 1, n rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) ) ik = ik + 1_${ik}$ end do rwork( k ) = rwork( k ) + s kk = kk + ( n-k+1 ) end do end if s = zero do i = 1, n if( rwork( i )>safe2 ) then s = max( s, cabs1( work( i ) ) / rwork( i ) ) else s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_cpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_clacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( rwork( i )>safe2 ) then rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) else rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). call stdlib${ii}$_cpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do call stdlib${ii}$_cpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, cabs1( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_cpprfs pure module subroutine stdlib${ii}$_zpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & !! ZPPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite !! and packed, and provides error bounds and backward error estimates !! for the solution. rwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments real(dp), intent(out) :: berr(*), ferr(*), rwork(*) complex(dp), intent(in) :: afp(*), ap(*), b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) ! ==================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(dp) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(dp) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -9_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPRFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_dlamch( 'EPSILON' ) safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_zcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ ) call stdlib${ii}$_zhpmv( uplo, n, -cone, ap, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n rwork( i ) = cabs1( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). kk = 1_${ik}$ if( upper ) then do k = 1, n s = zero xk = cabs1( x( k, j ) ) ik = kk do i = 1, k - 1 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) ) ik = ik + 1_${ik}$ end do rwork( k ) = rwork( k ) + abs( real( ap( kk+k-1 ),KIND=dp) )*xk + s kk = kk + k end do else do k = 1, n s = zero xk = cabs1( x( k, j ) ) rwork( k ) = rwork( k ) + abs( real( ap( kk ),KIND=dp) )*xk ik = kk + 1_${ik}$ do i = k + 1, n rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) ) ik = ik + 1_${ik}$ end do rwork( k ) = rwork( k ) + s kk = kk + ( n-k+1 ) end do end if s = zero do i = 1, n if( rwork( i )>safe2 ) then s = max( s, cabs1( work( i ) ) / rwork( i ) ) else s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_zpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_zlacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( rwork( i )>safe2 ) then rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) else rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). call stdlib${ii}$_zpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do call stdlib${ii}$_zpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, cabs1( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_zpprfs #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$pprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & !! ZPPRFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite !! and packed, and provides error bounds and backward error estimates !! for the solution. rwork, info ) ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) complex(${ck}$), intent(in) :: afp(*), ap(*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(inout) :: x(ldx,*) ! ==================================================================== ! Parameters integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars logical(lk) :: upper integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk complex(${ck}$) :: zdum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Statement Functions real(${ck}$) :: cabs1 ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ else if( nrhs<0_${ik}$ ) then info = -3_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ else if( ldx<max( 1_${ik}$, n ) ) then info = -9_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPRFS', -info ) return end if ! quick return if possible if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then do j = 1, nrhs ferr( j ) = zero berr( j ) = zero end do return end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1_${ik}$ eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_140: do j = 1, nrhs count = 1_${ik}$ lstres = three 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x call stdlib${ii}$_${ci}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ ) call stdlib${ii}$_${ci}$hpmv( uplo, n, -cone, ap, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix ! or vector z. if the i-th component of the denominator is less ! than safe2, then safe1 is added to the i-th components of the ! numerator and denominator before dividing. do i = 1, n rwork( i ) = cabs1( b( i, j ) ) end do ! compute abs(a)*abs(x) + abs(b). kk = 1_${ik}$ if( upper ) then do k = 1, n s = zero xk = cabs1( x( k, j ) ) ik = kk do i = 1, k - 1 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) ) ik = ik + 1_${ik}$ end do rwork( k ) = rwork( k ) + abs( real( ap( kk+k-1 ),KIND=${ck}$) )*xk + s kk = kk + k end do else do k = 1, n s = zero xk = cabs1( x( k, j ) ) rwork( k ) = rwork( k ) + abs( real( ap( kk ),KIND=${ck}$) )*xk ik = kk + 1_${ik}$ do i = k + 1, n rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) ) ik = ik + 1_${ik}$ end do rwork( k ) = rwork( k ) + s kk = kk + ( n-k+1 ) end do end if s = zero do i = 1, n if( rwork( i )>safe2 ) then s = max( s, cabs1( work( i ) ) / rwork( i ) ) else s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) ) end if end do berr( j ) = s ! test stopping criterion. continue iterating if ! 1) the residual berr(j) is larger than machine epsilon, and ! 2) berr(j) decreased by at least a factor of 2 during the ! last iteration, and ! 3) at most itmax iterations tried. if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. call stdlib${ii}$_${ci}$pptrs( uplo, n, 1_${ik}$, afp, work, n, info ) call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) count = count + 1_${ik}$ go to 20 end if ! bound error from formula ! norm(x - xtrue) / norm(x) .le. ferr = ! norm( abs(inv(a))* ! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x) ! where ! norm(z) is the magnitude of the largest component of z ! inv(a) is the inverse of a ! abs(z) is the componentwise absolute value of the matrix or ! vector z ! nz is the maximum number of nonzeros in any row of a, plus 1 ! eps is machine epsilon ! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(a)*abs(x) + abs(b) is less than safe2. ! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix ! inv(a) * diag(w), ! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) do i = 1, n if( rwork( i )>safe2 ) then rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) else rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do kase = 0_${ik}$ 100 continue call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0_${ik}$ ) then if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). call stdlib${ii}$_${ci}$pptrs( uplo, n, 1_${ik}$, afp, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do call stdlib${ii}$_${ci}$pptrs( uplo, n, 1_${ik}$, afp, work, n, info ) end if go to 100 end if ! normalize error. lstres = zero do i = 1, n lstres = max( lstres, cabs1( x( i, j ) ) ) end do if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return end subroutine stdlib${ii}$_${ci}$pprfs #:endif #:endfor pure module subroutine stdlib${ii}$_sppequ( uplo, n, ap, s, scond, amax, info ) !! SPPEQU computes row and column scalings intended to equilibrate a !! symmetric positive definite matrix A in packed storage and reduce !! its condition number (with respect to the two-norm). S contains the !! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix !! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. !! This choice of S puts the condition number of B within a factor N of !! the smallest possible condition number over all possible diagonal !! scalings. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(sp), intent(out) :: amax, scond ! Array Arguments real(sp), intent(in) :: ap(*) real(sp), intent(out) :: s(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i, jj real(sp) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPPEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! initialize smin and amax. s( 1_${ik}$ ) = ap( 1_${ik}$ ) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) if( upper ) then ! uplo = 'u': upper triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + i s( i ) = ap( jj ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do else ! uplo = 'l': lower triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + n - i + 2_${ik}$ s( i ) = ap( jj ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do end if if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_sppequ pure module subroutine stdlib${ii}$_dppequ( uplo, n, ap, s, scond, amax, info ) !! DPPEQU computes row and column scalings intended to equilibrate a !! symmetric positive definite matrix A in packed storage and reduce !! its condition number (with respect to the two-norm). S contains the !! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix !! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. !! This choice of S puts the condition number of B within a factor N of !! the smallest possible condition number over all possible diagonal !! scalings. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(dp), intent(out) :: amax, scond ! Array Arguments real(dp), intent(in) :: ap(*) real(dp), intent(out) :: s(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i, jj real(dp) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! initialize smin and amax. s( 1_${ik}$ ) = ap( 1_${ik}$ ) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) if( upper ) then ! uplo = 'u': upper triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + i s( i ) = ap( jj ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do else ! uplo = 'l': lower triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + n - i + 2_${ik}$ s( i ) = ap( jj ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do end if if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_dppequ #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$ppequ( uplo, n, ap, s, scond, amax, info ) !! DPPEQU: computes row and column scalings intended to equilibrate a !! symmetric positive definite matrix A in packed storage and reduce !! its condition number (with respect to the two-norm). S contains the !! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix !! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. !! This choice of S puts the condition number of B within a factor N of !! the smallest possible condition number over all possible diagonal !! scalings. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(${rk}$), intent(out) :: amax, scond ! Array Arguments real(${rk}$), intent(in) :: ap(*) real(${rk}$), intent(out) :: s(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i, jj real(${rk}$) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPPEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! initialize smin and amax. s( 1_${ik}$ ) = ap( 1_${ik}$ ) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) if( upper ) then ! uplo = 'u': upper triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + i s( i ) = ap( jj ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do else ! uplo = 'l': lower triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + n - i + 2_${ik}$ s( i ) = ap( jj ) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do end if if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_${ri}$ppequ #:endif #:endfor pure module subroutine stdlib${ii}$_cppequ( uplo, n, ap, s, scond, amax, info ) !! CPPEQU computes row and column scalings intended to equilibrate a !! Hermitian positive definite matrix A in packed storage and reduce !! its condition number (with respect to the two-norm). S contains the !! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix !! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. !! This choice of S puts the condition number of B within a factor N of !! the smallest possible condition number over all possible diagonal !! scalings. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(sp), intent(out) :: amax, scond ! Array Arguments real(sp), intent(out) :: s(*) complex(sp), intent(in) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i, jj real(sp) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPPEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! initialize smin and amax. s( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=sp) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) if( upper ) then ! uplo = 'u': upper triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + i s( i ) = real( ap( jj ),KIND=sp) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do else ! uplo = 'l': lower triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + n - i + 2_${ik}$ s( i ) = real( ap( jj ),KIND=sp) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do end if if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_cppequ pure module subroutine stdlib${ii}$_zppequ( uplo, n, ap, s, scond, amax, info ) !! ZPPEQU computes row and column scalings intended to equilibrate a !! Hermitian positive definite matrix A in packed storage and reduce !! its condition number (with respect to the two-norm). S contains the !! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix !! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. !! This choice of S puts the condition number of B within a factor N of !! the smallest possible condition number over all possible diagonal !! scalings. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(dp), intent(out) :: amax, scond ! Array Arguments real(dp), intent(out) :: s(*) complex(dp), intent(in) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i, jj real(dp) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! initialize smin and amax. s( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=dp) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) if( upper ) then ! uplo = 'u': upper triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + i s( i ) = real( ap( jj ),KIND=dp) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do else ! uplo = 'l': lower triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + n - i + 2_${ik}$ s( i ) = real( ap( jj ),KIND=dp) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do end if if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_zppequ #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$ppequ( uplo, n, ap, s, scond, amax, info ) !! ZPPEQU: computes row and column scalings intended to equilibrate a !! Hermitian positive definite matrix A in packed storage and reduce !! its condition number (with respect to the two-norm). S contains the !! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix !! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. !! This choice of S puts the condition number of B within a factor N of !! the smallest possible condition number over all possible diagonal !! scalings. ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n real(${ck}$), intent(out) :: amax, scond ! Array Arguments real(${ck}$), intent(out) :: s(*) complex(${ck}$), intent(in) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(${ik}$) :: i, jj real(${ck}$) :: smin ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info = -2_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPPEQU', -info ) return end if ! quick return if possible if( n==0_${ik}$ ) then scond = one amax = zero return end if ! initialize smin and amax. s( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=${ck}$) smin = s( 1_${ik}$ ) amax = s( 1_${ik}$ ) if( upper ) then ! uplo = 'u': upper triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + i s( i ) = real( ap( jj ),KIND=${ck}$) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do else ! uplo = 'l': lower triangle of a is stored. ! find the minimum and maximum diagonal elements. jj = 1_${ik}$ do i = 2, n jj = jj + n - i + 2_${ik}$ s( i ) = real( ap( jj ),KIND=${ck}$) smin = min( smin, s( i ) ) amax = max( amax, s( i ) ) end do end if if( smin<=zero ) then ! find the first non-positive diagonal element and return. do i = 1, n if( s( i )<=zero ) then info = i return end if end do else ! set the scale factors to the reciprocals ! of the diagonal elements. do i = 1, n s( i ) = one / sqrt( s( i ) ) end do ! compute scond = min(s(i)) / max(s(i)) scond = sqrt( smin ) / sqrt( amax ) end if return end subroutine stdlib${ii}$_${ci}$ppequ #:endif #:endfor pure module subroutine stdlib${ii}$_claqhp( uplo, n, ap, s, scond, amax, equed ) !! CLAQHP equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- 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(out) :: equed character, intent(in) :: uplo integer(${ik}$), intent(in) :: n real(sp), intent(in) :: amax, scond ! Array Arguments real(sp), intent(in) :: s(*) complex(sp), intent(inout) :: ap(*) ! ===================================================================== ! Parameters real(sp), parameter :: thresh = 0.1e+0_sp ! Local Scalars integer(${ik}$) :: i, j, jc real(sp) :: cj, large, small ! Intrinsic Functions ! Executable Statements ! quick return if possible if( n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration equed = 'N' else ! replace a by diag(s) * a * diag(s). if( stdlib_lsame( uplo, 'U' ) ) then ! upper triangle of a is stored. jc = 1_${ik}$ do j = 1, n cj = s( j ) do i = 1, j - 1 ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 ) end do ap( jc+j-1 ) = cj*cj*real( ap( jc+j-1 ),KIND=sp) jc = jc + j end do else ! lower triangle of a is stored. jc = 1_${ik}$ do j = 1, n cj = s( j ) ap( jc ) = cj*cj*real( ap( jc ),KIND=sp) do i = j + 1, n ap( jc+i-j ) = cj*s( i )*ap( jc+i-j ) end do jc = jc + n - j + 1_${ik}$ end do end if equed = 'Y' end if return end subroutine stdlib${ii}$_claqhp pure module subroutine stdlib${ii}$_zlaqhp( uplo, n, ap, s, scond, amax, equed ) !! ZLAQHP equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- 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(out) :: equed character, intent(in) :: uplo integer(${ik}$), intent(in) :: n real(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(in) :: s(*) complex(dp), intent(inout) :: ap(*) ! ===================================================================== ! Parameters real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars integer(${ik}$) :: i, j, jc real(dp) :: cj, large, small ! Intrinsic Functions ! Executable Statements ! quick return if possible if( n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration equed = 'N' else ! replace a by diag(s) * a * diag(s). if( stdlib_lsame( uplo, 'U' ) ) then ! upper triangle of a is stored. jc = 1_${ik}$ do j = 1, n cj = s( j ) do i = 1, j - 1 ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 ) end do ap( jc+j-1 ) = cj*cj*real( ap( jc+j-1 ),KIND=dp) jc = jc + j end do else ! lower triangle of a is stored. jc = 1_${ik}$ do j = 1, n cj = s( j ) ap( jc ) = cj*cj*real( ap( jc ),KIND=dp) do i = j + 1, n ap( jc+i-j ) = cj*s( i )*ap( jc+i-j ) end do jc = jc + n - j + 1_${ik}$ end do end if equed = 'Y' end if return end subroutine stdlib${ii}$_zlaqhp #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$laqhp( uplo, n, ap, s, scond, amax, equed ) !! ZLAQHP: equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- 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(out) :: equed character, intent(in) :: uplo integer(${ik}$), intent(in) :: n real(${ck}$), intent(in) :: amax, scond ! Array Arguments real(${ck}$), intent(in) :: s(*) complex(${ck}$), intent(inout) :: ap(*) ! ===================================================================== ! Parameters real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars integer(${ik}$) :: i, j, jc real(${ck}$) :: cj, large, small ! Intrinsic Functions ! Executable Statements ! quick return if possible if( n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration equed = 'N' else ! replace a by diag(s) * a * diag(s). if( stdlib_lsame( uplo, 'U' ) ) then ! upper triangle of a is stored. jc = 1_${ik}$ do j = 1, n cj = s( j ) do i = 1, j - 1 ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 ) end do ap( jc+j-1 ) = cj*cj*real( ap( jc+j-1 ),KIND=${ck}$) jc = jc + j end do else ! lower triangle of a is stored. jc = 1_${ik}$ do j = 1, n cj = s( j ) ap( jc ) = cj*cj*real( ap( jc ),KIND=${ck}$) do i = j + 1, n ap( jc+i-j ) = cj*s( i )*ap( jc+i-j ) end do jc = jc + n - j + 1_${ik}$ end do end if equed = 'Y' end if return end subroutine stdlib${ii}$_${ci}$laqhp #:endif #:endfor pure module subroutine stdlib${ii}$_spftrf( transr, uplo, n, a, info ) !! SPFTRF computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: transr, uplo integer(${ik}$), intent(in) :: n integer(${ik}$), intent(out) :: info ! Array Arguments real(sp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPFTRF', -info ) return end if ! quick return if possible if( n==0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution: there are eight cases if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_spotrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return call stdlib${ii}$_strsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0_${ik}$ ), n,a( n1 ), n ) call stdlib${ii}$_ssyrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) call stdlib${ii}$_spotrf( 'U', n2, a( n ), n, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_spotrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return call stdlib${ii}$_strsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_ssyrk( 'U', 'T', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) call stdlib${ii}$_spotrf( 'U', n2, a( n1 ), n, info ) if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 't' if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 call stdlib${ii}$_spotrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return call stdlib${ii}$_strsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0_${ik}$ ), n1,a( n1*n1 ), n1 & ) call stdlib${ii}$_ssyrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) call stdlib${ii}$_spotrf( 'L', n2, a( 1_${ik}$ ), n1, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 call stdlib${ii}$_spotrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return call stdlib${ii}$_strsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0_${ik}$ ), n2 & ) call stdlib${ii}$_ssyrk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) call stdlib${ii}$_spotrf( 'L', n2, a( n1*n2 ), n2, info ) if( info>0_${ik}$ )info = info + n1 end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_spotrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return call stdlib${ii}$_strsm( 'R', 'L', 'T', 'N', k, k, one, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_ssyrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_spotrf( 'U', k, a( 0_${ik}$ ), n+1, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_spotrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return call stdlib${ii}$_strsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_ssyrk( 'U', 'T', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) call stdlib${ii}$_spotrf( 'U', k, a( k ), n+1, info ) if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 't' if( lower ) then ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_spotrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return call stdlib${ii}$_strsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), & k ) call stdlib${ii}$_ssyrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) call stdlib${ii}$_spotrf( 'L', k, a( 0_${ik}$ ), k, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_spotrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return call stdlib${ii}$_strsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), k & ) call stdlib${ii}$_ssyrk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) call stdlib${ii}$_spotrf( 'L', k, a( k*k ), k, info ) if( info>0_${ik}$ )info = info + k end if end if end if return end subroutine stdlib${ii}$_spftrf pure module subroutine stdlib${ii}$_dpftrf( transr, uplo, n, a, info ) !! DPFTRF computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: transr, uplo integer(${ik}$), intent(in) :: n integer(${ik}$), intent(out) :: info ! Array Arguments real(dp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPFTRF', -info ) return end if ! quick return if possible if( n==0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution: there are eight cases if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_dpotrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return call stdlib${ii}$_dtrsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0_${ik}$ ), n,a( n1 ), n ) call stdlib${ii}$_dsyrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) call stdlib${ii}$_dpotrf( 'U', n2, a( n ), n, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_dpotrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return call stdlib${ii}$_dtrsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_dsyrk( 'U', 'T', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) call stdlib${ii}$_dpotrf( 'U', n2, a( n1 ), n, info ) if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 't' if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 call stdlib${ii}$_dpotrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return call stdlib${ii}$_dtrsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0_${ik}$ ), n1,a( n1*n1 ), n1 & ) call stdlib${ii}$_dsyrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) call stdlib${ii}$_dpotrf( 'L', n2, a( 1_${ik}$ ), n1, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 call stdlib${ii}$_dpotrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return call stdlib${ii}$_dtrsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0_${ik}$ ), n2 & ) call stdlib${ii}$_dsyrk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) call stdlib${ii}$_dpotrf( 'L', n2, a( n1*n2 ), n2, info ) if( info>0_${ik}$ )info = info + n1 end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_dpotrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return call stdlib${ii}$_dtrsm( 'R', 'L', 'T', 'N', k, k, one, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_dsyrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_dpotrf( 'U', k, a( 0_${ik}$ ), n+1, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_dpotrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return call stdlib${ii}$_dtrsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_dsyrk( 'U', 'T', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) call stdlib${ii}$_dpotrf( 'U', k, a( k ), n+1, info ) if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 't' if( lower ) then ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_dpotrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return call stdlib${ii}$_dtrsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), & k ) call stdlib${ii}$_dsyrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) call stdlib${ii}$_dpotrf( 'L', k, a( 0_${ik}$ ), k, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_dpotrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return call stdlib${ii}$_dtrsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), k & ) call stdlib${ii}$_dsyrk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) call stdlib${ii}$_dpotrf( 'L', k, a( k*k ), k, info ) if( info>0_${ik}$ )info = info + k end if end if end if return end subroutine stdlib${ii}$_dpftrf #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$pftrf( transr, uplo, n, a, info ) !! DPFTRF: computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form !! A = U**T * U, if UPLO = 'U', or !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: transr, uplo integer(${ik}$), intent(in) :: n integer(${ik}$), intent(out) :: info ! Array Arguments real(${rk}$), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPFTRF', -info ) return end if ! quick return if possible if( n==0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution: there are eight cases if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_${ri}$potrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return call stdlib${ii}$_${ri}$trsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0_${ik}$ ), n,a( n1 ), n ) call stdlib${ii}$_${ri}$syrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) call stdlib${ii}$_${ri}$potrf( 'U', n2, a( n ), n, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_${ri}$potrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return call stdlib${ii}$_${ri}$trsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_${ri}$syrk( 'U', 'T', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) call stdlib${ii}$_${ri}$potrf( 'U', n2, a( n1 ), n, info ) if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 't' if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 call stdlib${ii}$_${ri}$potrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return call stdlib${ii}$_${ri}$trsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0_${ik}$ ), n1,a( n1*n1 ), n1 & ) call stdlib${ii}$_${ri}$syrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) call stdlib${ii}$_${ri}$potrf( 'L', n2, a( 1_${ik}$ ), n1, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 call stdlib${ii}$_${ri}$potrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return call stdlib${ii}$_${ri}$trsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0_${ik}$ ), n2 & ) call stdlib${ii}$_${ri}$syrk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) call stdlib${ii}$_${ri}$potrf( 'L', n2, a( n1*n2 ), n2, info ) if( info>0_${ik}$ )info = info + n1 end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_${ri}$potrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return call stdlib${ii}$_${ri}$trsm( 'R', 'L', 'T', 'N', k, k, one, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_${ri}$syrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_${ri}$potrf( 'U', k, a( 0_${ik}$ ), n+1, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_${ri}$potrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return call stdlib${ii}$_${ri}$trsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_${ri}$syrk( 'U', 'T', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) call stdlib${ii}$_${ri}$potrf( 'U', k, a( k ), n+1, info ) if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 't' if( lower ) then ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_${ri}$potrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return call stdlib${ii}$_${ri}$trsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), & k ) call stdlib${ii}$_${ri}$syrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) call stdlib${ii}$_${ri}$potrf( 'L', k, a( 0_${ik}$ ), k, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_${ri}$potrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return call stdlib${ii}$_${ri}$trsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), k & ) call stdlib${ii}$_${ri}$syrk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) call stdlib${ii}$_${ri}$potrf( 'L', k, a( k*k ), k, info ) if( info>0_${ik}$ )info = info + k end if end if end if return end subroutine stdlib${ii}$_${ri}$pftrf #:endif #:endfor pure module subroutine stdlib${ii}$_cpftrf( transr, uplo, n, a, info ) !! CPFTRF computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: transr, uplo integer(${ik}$), intent(in) :: n integer(${ik}$), intent(out) :: info ! Array Arguments complex(sp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPFTRF', -info ) return end if ! quick return if possible if( n==0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution: there are eight cases if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_cpotrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return call stdlib${ii}$_ctrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0_${ik}$ ), n,a( n1 ), n ) call stdlib${ii}$_cherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) call stdlib${ii}$_cpotrf( 'U', n2, a( n ), n, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_cpotrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_cherk( 'U', 'C', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) call stdlib${ii}$_cpotrf( 'U', n2, a( n1 ), n, info ) if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 'c' if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 call stdlib${ii}$_cpotrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0_${ik}$ ), n1,a( n1*n1 ), & n1 ) call stdlib${ii}$_cherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) call stdlib${ii}$_cpotrf( 'L', n2, a( 1_${ik}$ ), n1, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 call stdlib${ii}$_cpotrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return call stdlib${ii}$_ctrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0_${ik}$ ), & n2 ) call stdlib${ii}$_cherk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) call stdlib${ii}$_cpotrf( 'L', n2, a( n1*n2 ), n2, info ) if( info>0_${ik}$ )info = info + n1 end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_cpotrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return call stdlib${ii}$_ctrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_cherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_cpotrf( 'U', k, a( 0_${ik}$ ), n+1, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_cpotrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_cherk( 'U', 'C', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) call stdlib${ii}$_cpotrf( 'U', k, a( k ), n+1, info ) if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 'c' if( lower ) then ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_cpotrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & k ) call stdlib${ii}$_cherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) call stdlib${ii}$_cpotrf( 'L', k, a( 0_${ik}$ ), k, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_cpotrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return call stdlib${ii}$_ctrsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ), & k ) call stdlib${ii}$_cherk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) call stdlib${ii}$_cpotrf( 'L', k, a( k*k ), k, info ) if( info>0_${ik}$ )info = info + k end if end if end if return end subroutine stdlib${ii}$_cpftrf pure module subroutine stdlib${ii}$_zpftrf( transr, uplo, n, a, info ) !! ZPFTRF computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: transr, uplo integer(${ik}$), intent(in) :: n integer(${ik}$), intent(out) :: info ! Array Arguments complex(dp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPFTRF', -info ) return end if ! quick return if possible if( n==0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution: there are eight cases if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_zpotrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return call stdlib${ii}$_ztrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0_${ik}$ ), n,a( n1 ), n ) call stdlib${ii}$_zherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) call stdlib${ii}$_zpotrf( 'U', n2, a( n ), n, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_zpotrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_zherk( 'U', 'C', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) call stdlib${ii}$_zpotrf( 'U', n2, a( n1 ), n, info ) if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 'c' if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 call stdlib${ii}$_zpotrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0_${ik}$ ), n1,a( n1*n1 ), & n1 ) call stdlib${ii}$_zherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) call stdlib${ii}$_zpotrf( 'L', n2, a( 1_${ik}$ ), n1, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 call stdlib${ii}$_zpotrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return call stdlib${ii}$_ztrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0_${ik}$ ), & n2 ) call stdlib${ii}$_zherk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) call stdlib${ii}$_zpotrf( 'L', n2, a( n1*n2 ), n2, info ) if( info>0_${ik}$ )info = info + n1 end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_zpotrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return call stdlib${ii}$_ztrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_zherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_zpotrf( 'U', k, a( 0_${ik}$ ), n+1, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_zpotrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_zherk( 'U', 'C', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) call stdlib${ii}$_zpotrf( 'U', k, a( k ), n+1, info ) if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 'c' if( lower ) then ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_zpotrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & k ) call stdlib${ii}$_zherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) call stdlib${ii}$_zpotrf( 'L', k, a( 0_${ik}$ ), k, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_zpotrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return call stdlib${ii}$_ztrsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ), & k ) call stdlib${ii}$_zherk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) call stdlib${ii}$_zpotrf( 'L', k, a( k*k ), k, info ) if( info>0_${ik}$ )info = info + k end if end if end if return end subroutine stdlib${ii}$_zpftrf #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$pftrf( transr, uplo, n, a, info ) !! ZPFTRF: computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. ! -- 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) :: transr, uplo integer(${ik}$), intent(in) :: n integer(${ik}$), intent(out) :: info ! Array Arguments complex(${ck}$), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPFTRF', -info ) return end if ! quick return if possible if( n==0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution: there are eight cases if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_${ci}$potrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return call stdlib${ii}$_${ci}$trsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0_${ik}$ ), n,a( n1 ), n ) call stdlib${ii}$_${ci}$herk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) call stdlib${ii}$_${ci}$potrf( 'U', n2, a( n ), n, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_${ci}$potrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_${ci}$herk( 'U', 'C', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) call stdlib${ii}$_${ci}$potrf( 'U', n2, a( n1 ), n, info ) if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 'c' if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 call stdlib${ii}$_${ci}$potrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0_${ik}$ ), n1,a( n1*n1 ), & n1 ) call stdlib${ii}$_${ci}$herk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) call stdlib${ii}$_${ci}$potrf( 'L', n2, a( 1_${ik}$ ), n1, info ) if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 call stdlib${ii}$_${ci}$potrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return call stdlib${ii}$_${ci}$trsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0_${ik}$ ), & n2 ) call stdlib${ii}$_${ci}$herk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) call stdlib${ii}$_${ci}$potrf( 'L', n2, a( n1*n2 ), n2, info ) if( info>0_${ik}$ )info = info + n1 end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_${ci}$potrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return call stdlib${ii}$_${ci}$trsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_${ci}$herk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_${ci}$potrf( 'U', k, a( 0_${ik}$ ), n+1, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_${ci}$potrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_${ci}$herk( 'U', 'C', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) call stdlib${ii}$_${ci}$potrf( 'U', k, a( k ), n+1, info ) if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 'c' if( lower ) then ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_${ci}$potrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & k ) call stdlib${ii}$_${ci}$herk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) call stdlib${ii}$_${ci}$potrf( 'L', k, a( 0_${ik}$ ), k, info ) if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_${ci}$potrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return call stdlib${ii}$_${ci}$trsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ), & k ) call stdlib${ii}$_${ci}$herk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) call stdlib${ii}$_${ci}$potrf( 'L', k, a( k*k ), k, info ) if( info>0_${ik}$ )info = info + k end if end if end if return end subroutine stdlib${ii}$_${ci}$pftrf #:endif #:endfor pure module subroutine stdlib${ii}$_spftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! SPFTRS solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A using the Cholesky factorization !! A = U**T*U or A = L*L**T computed by SPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(sp), intent(in) :: a(0_${ik}$:*) real(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, normaltransr ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ else if( nrhs<0_${ik}$ ) then info = -4_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPFTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return ! start execution: there are two triangular solves if( lower ) then call stdlib${ii}$_stfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb ) call stdlib${ii}$_stfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb ) else call stdlib${ii}$_stfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb ) call stdlib${ii}$_stfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb ) end if return end subroutine stdlib${ii}$_spftrs pure module subroutine stdlib${ii}$_dpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! DPFTRS solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A using the Cholesky factorization !! A = U**T*U or A = L*L**T computed by DPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(dp), intent(in) :: a(0_${ik}$:*) real(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, normaltransr ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ else if( nrhs<0_${ik}$ ) then info = -4_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPFTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return ! start execution: there are two triangular solves if( lower ) then call stdlib${ii}$_dtfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb ) call stdlib${ii}$_dtfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb ) else call stdlib${ii}$_dtfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb ) call stdlib${ii}$_dtfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb ) end if return end subroutine stdlib${ii}$_dpftrs #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$pftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! DPFTRS: solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A using the Cholesky factorization !! A = U**T*U or A = L*L**T computed by DPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(${rk}$), intent(in) :: a(0_${ik}$:*) real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, normaltransr ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ else if( nrhs<0_${ik}$ ) then info = -4_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPFTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return ! start execution: there are two triangular solves if( lower ) then call stdlib${ii}$_${ri}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb ) call stdlib${ii}$_${ri}$tfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb ) else call stdlib${ii}$_${ri}$tfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb ) call stdlib${ii}$_${ri}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb ) end if return end subroutine stdlib${ii}$_${ri}$pftrs #:endif #:endfor pure module subroutine stdlib${ii}$_cpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! CPFTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by CPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments complex(sp), intent(in) :: a(0_${ik}$:*) complex(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, normaltransr ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ else if( nrhs<0_${ik}$ ) then info = -4_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPFTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return ! start execution: there are two triangular solves if( lower ) then call stdlib${ii}$_ctfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb ) call stdlib${ii}$_ctfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb ) else call stdlib${ii}$_ctfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb ) call stdlib${ii}$_ctfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb ) end if return end subroutine stdlib${ii}$_cpftrs pure module subroutine stdlib${ii}$_zpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! ZPFTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by ZPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments complex(dp), intent(in) :: a(0_${ik}$:*) complex(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, normaltransr ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ else if( nrhs<0_${ik}$ ) then info = -4_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPFTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return ! start execution: there are two triangular solves if( lower ) then call stdlib${ii}$_ztfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb ) call stdlib${ii}$_ztfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb ) else call stdlib${ii}$_ztfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb ) call stdlib${ii}$_ztfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb ) end if return end subroutine stdlib${ii}$_zpftrs #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$pftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! ZPFTRS: solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by ZPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments complex(${ck}$), intent(in) :: a(0_${ik}$:*) complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, normaltransr ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ else if( nrhs<0_${ik}$ ) then info = -4_${ik}$ else if( ldb<max( 1_${ik}$, n ) ) then info = -7_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPFTRS', -info ) return end if ! quick return if possible if( n==0 .or. nrhs==0 )return ! start execution: there are two triangular solves if( lower ) then call stdlib${ii}$_${ci}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb ) call stdlib${ii}$_${ci}$tfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb ) else call stdlib${ii}$_${ci}$tfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb ) call stdlib${ii}$_${ci}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb ) end if return end subroutine stdlib${ii}$_${ci}$pftrs #:endif #:endfor pure module subroutine stdlib${ii}$_spftri( transr, uplo, n, a, info ) !! SPFTRI computes the inverse of a real (symmetric) positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by SPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments real(sp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'SPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_stftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or ! inv(l)^c*inv(l). there are eight cases. if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_slauum( 'L', n1, a( 0_${ik}$ ), n, info ) call stdlib${ii}$_ssyrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n ) call stdlib${ii}$_slauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_slauum( 'L', n1, a( n2 ), n, info ) call stdlib${ii}$_ssyrk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) call stdlib${ii}$_strmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_slauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 't' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) call stdlib${ii}$_slauum( 'U', n1, a( 0_${ik}$ ), n1, info ) call stdlib${ii}$_ssyrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) call stdlib${ii}$_strmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1_${ik}$ ), n1,a( n1*n1 ), n1 & ) call stdlib${ii}$_slauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) call stdlib${ii}$_slauum( 'U', n1, a( n2*n2 ), n2, info ) call stdlib${ii}$_ssyrk( 'U', 'T', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) call stdlib${ii}$_strmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0_${ik}$ ), n2 & ) call stdlib${ii}$_slauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_slauum( 'L', k, a( 1_${ik}$ ), n+1, info ) call stdlib${ii}$_ssyrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_slauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_slauum( 'L', k, a( k+1 ), n+1, info ) call stdlib${ii}$_ssyrk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) call stdlib${ii}$_strmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_slauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 't' if( lower ) then ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_slauum( 'U', k, a( k ), k, info ) call stdlib${ii}$_ssyrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) call stdlib${ii}$_strmm( 'R', 'L', 'N', 'N', k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), k & ) call stdlib${ii}$_slauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_slauum( 'U', k, a( k*( k+1 ) ), k, info ) call stdlib${ii}$_ssyrk( 'U', 'T', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) call stdlib${ii}$_strmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0_${ik}$ ), k ) call stdlib${ii}$_slauum( 'L', k, a( k*k ), k, info ) end if end if end if return end subroutine stdlib${ii}$_spftri pure module subroutine stdlib${ii}$_dpftri( transr, uplo, n, a, info ) !! DPFTRI computes the inverse of a (real) symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by DPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments real(dp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_dtftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or ! inv(l)^c*inv(l). there are eight cases. if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_dlauum( 'L', n1, a( 0_${ik}$ ), n, info ) call stdlib${ii}$_dsyrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n ) call stdlib${ii}$_dlauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_dlauum( 'L', n1, a( n2 ), n, info ) call stdlib${ii}$_dsyrk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) call stdlib${ii}$_dtrmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_dlauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 't' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) call stdlib${ii}$_dlauum( 'U', n1, a( 0_${ik}$ ), n1, info ) call stdlib${ii}$_dsyrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) call stdlib${ii}$_dtrmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1_${ik}$ ), n1,a( n1*n1 ), n1 & ) call stdlib${ii}$_dlauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) call stdlib${ii}$_dlauum( 'U', n1, a( n2*n2 ), n2, info ) call stdlib${ii}$_dsyrk( 'U', 'T', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0_${ik}$ ), n2 & ) call stdlib${ii}$_dlauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_dlauum( 'L', k, a( 1_${ik}$ ), n+1, info ) call stdlib${ii}$_dsyrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_dlauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_dlauum( 'L', k, a( k+1 ), n+1, info ) call stdlib${ii}$_dsyrk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) call stdlib${ii}$_dtrmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_dlauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 't' if( lower ) then ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_dlauum( 'U', k, a( k ), k, info ) call stdlib${ii}$_dsyrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) call stdlib${ii}$_dtrmm( 'R', 'L', 'N', 'N', k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), k & ) call stdlib${ii}$_dlauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_dlauum( 'U', k, a( k*( k+1 ) ), k, info ) call stdlib${ii}$_dsyrk( 'U', 'T', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0_${ik}$ ), k ) call stdlib${ii}$_dlauum( 'L', k, a( k*k ), k, info ) end if end if end if return end subroutine stdlib${ii}$_dpftri #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] pure module subroutine stdlib${ii}$_${ri}$pftri( transr, uplo, n, a, info ) !! DPFTRI: computes the inverse of a (real) symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by DPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments real(${rk}$), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'DPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_${ri}$tftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or ! inv(l)^c*inv(l). there are eight cases. if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_${ri}$lauum( 'L', n1, a( 0_${ik}$ ), n, info ) call stdlib${ii}$_${ri}$syrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n ) call stdlib${ii}$_${ri}$lauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_${ri}$lauum( 'L', n1, a( n2 ), n, info ) call stdlib${ii}$_${ri}$syrk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_${ri}$lauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 't' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) call stdlib${ii}$_${ri}$lauum( 'U', n1, a( 0_${ik}$ ), n1, info ) call stdlib${ii}$_${ri}$syrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) call stdlib${ii}$_${ri}$trmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1_${ik}$ ), n1,a( n1*n1 ), n1 & ) call stdlib${ii}$_${ri}$lauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) call stdlib${ii}$_${ri}$lauum( 'U', n1, a( n2*n2 ), n2, info ) call stdlib${ii}$_${ri}$syrk( 'U', 'T', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0_${ik}$ ), n2 & ) call stdlib${ii}$_${ri}$lauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_${ri}$lauum( 'L', k, a( 1_${ik}$ ), n+1, info ) call stdlib${ii}$_${ri}$syrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', 'N', k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_${ri}$lauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_${ri}$lauum( 'L', k, a( k+1 ), n+1, info ) call stdlib${ii}$_${ri}$syrk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_${ri}$lauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 't' if( lower ) then ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_${ri}$lauum( 'U', k, a( k ), k, info ) call stdlib${ii}$_${ri}$syrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) call stdlib${ii}$_${ri}$trmm( 'R', 'L', 'N', 'N', k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), k & ) call stdlib${ii}$_${ri}$lauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_${ri}$lauum( 'U', k, a( k*( k+1 ) ), k, info ) call stdlib${ii}$_${ri}$syrk( 'U', 'T', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0_${ik}$ ), k ) call stdlib${ii}$_${ri}$lauum( 'L', k, a( k*k ), k, info ) end if end if end if return end subroutine stdlib${ii}$_${ri}$pftri #:endif #:endfor pure module subroutine stdlib${ii}$_cpftri( transr, uplo, n, a, info ) !! CPFTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by CPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments complex(sp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'CPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_ctftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or ! inv(l)^c*inv(l). there are eight cases. if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_clauum( 'L', n1, a( 0_${ik}$ ), n, info ) call stdlib${ii}$_cherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) call stdlib${ii}$_clauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_clauum( 'L', n1, a( n2 ), n, info ) call stdlib${ii}$_cherk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) call stdlib${ii}$_ctrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_clauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 'c' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) call stdlib${ii}$_clauum( 'U', n1, a( 0_${ik}$ ), n1, info ) call stdlib${ii}$_cherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) call stdlib${ii}$_ctrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1_${ik}$ ), n1,a( n1*n1 ), & n1 ) call stdlib${ii}$_clauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) call stdlib${ii}$_clauum( 'U', n1, a( n2*n2 ), n2, info ) call stdlib${ii}$_cherk( 'U', 'C', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0_${ik}$ ), & n2 ) call stdlib${ii}$_clauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_clauum( 'L', k, a( 1_${ik}$ ), n+1, info ) call stdlib${ii}$_cherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_clauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_clauum( 'L', k, a( k+1 ), n+1, info ) call stdlib${ii}$_cherk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) call stdlib${ii}$_ctrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_clauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 'c' if( lower ) then ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_clauum( 'U', k, a( k ), k, info ) call stdlib${ii}$_cherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) call stdlib${ii}$_ctrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), & k ) call stdlib${ii}$_clauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_clauum( 'U', k, a( k*( k+1 ) ), k, info ) call stdlib${ii}$_cherk( 'U', 'C', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k ) call stdlib${ii}$_clauum( 'L', k, a( k*k ), k, info ) end if end if end if return end subroutine stdlib${ii}$_cpftri pure module subroutine stdlib${ii}$_zpftri( transr, uplo, n, a, info ) !! ZPFTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments complex(dp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_ztftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or ! inv(l)^c*inv(l). there are eight cases. if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_zlauum( 'L', n1, a( 0_${ik}$ ), n, info ) call stdlib${ii}$_zherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) call stdlib${ii}$_zlauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_zlauum( 'L', n1, a( n2 ), n, info ) call stdlib${ii}$_zherk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) call stdlib${ii}$_ztrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_zlauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 'c' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) call stdlib${ii}$_zlauum( 'U', n1, a( 0_${ik}$ ), n1, info ) call stdlib${ii}$_zherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) call stdlib${ii}$_ztrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1_${ik}$ ), n1,a( n1*n1 ), & n1 ) call stdlib${ii}$_zlauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) call stdlib${ii}$_zlauum( 'U', n1, a( n2*n2 ), n2, info ) call stdlib${ii}$_zherk( 'U', 'C', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0_${ik}$ ), & n2 ) call stdlib${ii}$_zlauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_zlauum( 'L', k, a( 1_${ik}$ ), n+1, info ) call stdlib${ii}$_zherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_zlauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_zlauum( 'L', k, a( k+1 ), n+1, info ) call stdlib${ii}$_zherk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) call stdlib${ii}$_ztrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_zlauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 'c' if( lower ) then ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_zlauum( 'U', k, a( k ), k, info ) call stdlib${ii}$_zherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) call stdlib${ii}$_ztrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), & k ) call stdlib${ii}$_zlauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_zlauum( 'U', k, a( k*( k+1 ) ), k, info ) call stdlib${ii}$_zherk( 'U', 'C', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k ) call stdlib${ii}$_zlauum( 'L', k, a( k*k ), k, info ) end if end if end if return end subroutine stdlib${ii}$_zpftri #:for ck,ct,ci in CMPLX_KINDS_TYPES #:if not ck in ["sp","dp"] pure module subroutine stdlib${ii}$_${ci}$pftri( transr, uplo, n, a, info ) !! ZPFTRI: computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPFTRF. ! -- 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) :: transr, uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: n ! Array Arguments complex(${ck}$), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr integer(${ik}$) :: n1, n2, k ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then info = -2_${ik}$ else if( n<0_${ik}$ ) then info = -3_${ik}$ end if if( info/=0_${ik}$ ) then call stdlib${ii}$_xerbla( 'ZPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. call stdlib${ii}$_${ci}$tftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. if( mod( n, 2_${ik}$ )==0_${ik}$ ) then k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then n2 = n / 2_${ik}$ n1 = n - n2 else n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or ! inv(l)^c*inv(l). there are eight cases. if( nisodd ) then ! n is odd if( normaltransr ) then ! n is odd and transr = 'n' if( lower ) then ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) call stdlib${ii}$_${ci}$lauum( 'L', n1, a( 0_${ik}$ ), n, info ) call stdlib${ii}$_${ci}$herk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) call stdlib${ii}$_${ci}$lauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) call stdlib${ii}$_${ci}$lauum( 'L', n1, a( n2 ), n, info ) call stdlib${ii}$_${ci}$herk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0_${ik}$ ), n ) call stdlib${ii}$_${ci}$lauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 'c' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) call stdlib${ii}$_${ci}$lauum( 'U', n1, a( 0_${ik}$ ), n1, info ) call stdlib${ii}$_${ci}$herk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1_${ik}$ ), n1,a( n1*n1 ), & n1 ) call stdlib${ii}$_${ci}$lauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) call stdlib${ii}$_${ci}$lauum( 'U', n1, a( n2*n2 ), n2, info ) call stdlib${ii}$_${ci}$herk( 'U', 'C', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0_${ik}$ ), & n2 ) call stdlib${ii}$_${ci}$lauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else ! n is even if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) call stdlib${ii}$_${ci}$lauum( 'L', k, a( 1_${ik}$ ), n+1, info ) call stdlib${ii}$_${ci}$herk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) call stdlib${ii}$_${ci}$lauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) call stdlib${ii}$_${ci}$lauum( 'L', k, a( k+1 ), n+1, info ) call stdlib${ii}$_${ci}$herk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 ) call stdlib${ii}$_${ci}$lauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 'c' if( lower ) then ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k call stdlib${ii}$_${ci}$lauum( 'U', k, a( k ), k, info ) call stdlib${ii}$_${ci}$herk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), & k ) call stdlib${ii}$_${ci}$lauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k call stdlib${ii}$_${ci}$lauum( 'U', k, a( k*( k+1 ) ), k, info ) call stdlib${ii}$_${ci}$herk( 'U', 'C', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k ) call stdlib${ii}$_${ci}$lauum( 'L', k, a( k*k ), k, info ) end if end if end if return end subroutine stdlib${ii}$_${ci}$pftri #:endif #:endfor pure module subroutine stdlib${ii}$_spbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,iwork, info ) !! SPBCON estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric positive definite band matrix using the !! Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! -- 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) :: uplo integer(${ik}$), intent(out) :: info integer(${ik}$), intent(in) :: kd, ldab, n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(in) :: ab(ldab,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(${ik}$) :: ix, kase real(sp) :: ainvnm, scale, scalel, scaleu, smlnum ! Local Arrays integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions ! Executable Statements ! test the input parameters. info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then info = -1_${ik}$ else if( n<0_${ik}$ ) then info =