stdlib_lapack_solve_chol_comp.fypp Source File


Source Code

#: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 =