stdlib_lapack_solve_ldl_comp2.fypp Source File


Source Code

#:include "common.fypp" 
submodule(stdlib_lapack_solve) stdlib_lapack_solve_ldl_comp2
  implicit none


  contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES

     pure module subroutine stdlib${ii}$_ssptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
     !! SSPTRS solves a system of linear equations A*X = B with a real
     !! symmetric matrix A stored in packed format using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(sp), intent(in) :: ap(*)
           real(sp), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kp
           real(sp) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'SSPTRS', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              kc = kc - k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_sger( k-1, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_sscal( nrhs, one / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k-1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k-1 )call stdlib${ii}$_sswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 call stdlib${ii}$_sger( k-2, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 call stdlib${ii}$_sger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, 1_${ik}$ &
                           ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+k-2 )
                 akm1 = ap( kc-1 ) / akm1k
                 ak = ap( kc+k-1 ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc - k + 1_${ik}$
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
                           1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + k
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
                           1_${ik}$ ), ldb )
                 call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,ap( kc+k ), 1_${ik}$, one, b( k+&
                           1_${ik}$, 1_${ik}$ ), ldb )
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + 2_${ik}$*k + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_sger( n-k, nrhs, -one, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+1,&
                            1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_sscal( nrhs, one / ap( kc ), b( k, 1_${ik}$ ), ldb )
                 kc = kc + n - k + 1_${ik}$
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k+1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k+1 )call stdlib${ii}$_sswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_sger( n-k-1, nrhs, -one, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ )&
                              , ldb )
                    call stdlib${ii}$_sger( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
                              2_${ik}$, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+1 )
                 akm1 = ap( kc ) / akm1k
                 ak = ap( kc+n-k+1 ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              kc = kc - ( n-k+1 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( &
                           kc+1 ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ), &
                              1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
                              k ) ), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc - ( n-k+2 )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_ssptrs

     pure module subroutine stdlib${ii}$_dsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
     !! DSPTRS solves a system of linear equations A*X = B with a real
     !! symmetric matrix A stored in packed format using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(dp), intent(in) :: ap(*)
           real(dp), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kp
           real(dp) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSPTRS', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              kc = kc - k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_dger( k-1, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_dscal( nrhs, one / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k-1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k-1 )call stdlib${ii}$_dswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 call stdlib${ii}$_dger( k-2, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 call stdlib${ii}$_dger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, 1_${ik}$ &
                           ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+k-2 )
                 akm1 = ap( kc-1 ) / akm1k
                 ak = ap( kc+k-1 ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc - k + 1_${ik}$
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
                           1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + k
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
                           1_${ik}$ ), ldb )
                 call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,ap( kc+k ), 1_${ik}$, one, b( k+&
                           1_${ik}$, 1_${ik}$ ), ldb )
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + 2_${ik}$*k + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_dger( n-k, nrhs, -one, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+1,&
                            1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_dscal( nrhs, one / ap( kc ), b( k, 1_${ik}$ ), ldb )
                 kc = kc + n - k + 1_${ik}$
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k+1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k+1 )call stdlib${ii}$_dswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_dger( n-k-1, nrhs, -one, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ )&
                              , ldb )
                    call stdlib${ii}$_dger( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
                              2_${ik}$, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+1 )
                 akm1 = ap( kc ) / akm1k
                 ak = ap( kc+n-k+1 ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              kc = kc - ( n-k+1 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( &
                           kc+1 ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ), &
                              1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
                              k ) ), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc - ( n-k+2 )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_dsptrs

#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ri}$sptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
     !! DSPTRS: solves a system of linear equations A*X = B with a real
     !! symmetric matrix A stored in packed format using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(${rk}$), intent(in) :: ap(*)
           real(${rk}$), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kp
           real(${rk}$) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSPTRS', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              kc = kc - k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_${ri}$ger( k-1, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_${ri}$scal( nrhs, one / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k-1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k-1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 call stdlib${ii}$_${ri}$ger( k-2, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 call stdlib${ii}$_${ri}$ger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, 1_${ik}$ &
                           ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+k-2 )
                 akm1 = ap( kc-1 ) / akm1k
                 ak = ap( kc+k-1 ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc - k + 1_${ik}$
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
                           1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + k
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, &
                           1_${ik}$ ), ldb )
                 call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,ap( kc+k ), 1_${ik}$, one, b( k+&
                           1_${ik}$, 1_${ik}$ ), ldb )
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + 2_${ik}$*k + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_${ri}$ger( n-k, nrhs, -one, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+1,&
                            1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_${ri}$scal( nrhs, one / ap( kc ), b( k, 1_${ik}$ ), ldb )
                 kc = kc + n - k + 1_${ik}$
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k+1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k+1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_${ri}$ger( n-k-1, nrhs, -one, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ )&
                              , ldb )
                    call stdlib${ii}$_${ri}$ger( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
                              2_${ik}$, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+1 )
                 akm1 = ap( kc ) / akm1k
                 ak = ap( kc+n-k+1 ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              kc = kc - ( n-k+1 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( &
                           kc+1 ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ), &
                              1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
                              k ) ), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc - ( n-k+2 )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_${ri}$sptrs

#:endif
#:endfor

     pure module subroutine stdlib${ii}$_csptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
     !! CSPTRS solves a system of linear equations A*X = B with a complex
     !! symmetric matrix A stored in packed format using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by CSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(sp), intent(in) :: ap(*)
           complex(sp), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kp
           complex(sp) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'CSPTRS', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              kc = kc - k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_cgeru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_cscal( nrhs, cone / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k-1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 call stdlib${ii}$_cgeru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 call stdlib${ii}$_cgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, &
                           1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+k-2 )
                 akm1 = ap( kc-1 ) / akm1k
                 ak = ap( kc+k-1 ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc - k + 1_${ik}$
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
                            1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + k
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
                            1_${ik}$ ), ldb )
                 call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1_${ik}$, cone, b( &
                           k+1, 1_${ik}$ ), ldb )
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + 2_${ik}$*k + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_cgeru( n-k, nrhs, -cone, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
                           1_${ik}$, 1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_cscal( nrhs, cone / ap( kc ), b( k, 1_${ik}$ ), ldb )
                 kc = kc + n - k + 1_${ik}$
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k+1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k+1 )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_cgeru( n-k-1, nrhs, -cone, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
                              1_${ik}$ ), ldb )
                    call stdlib${ii}$_cgeru( n-k-1, nrhs, -cone, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
                              k+2, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+1 )
                 akm1 = ap( kc ) / akm1k
                 ak = ap( kc+n-k+1 ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              kc = kc - ( n-k+1 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( &
                           kc+1 ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ),&
                               1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
                              k ) ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc - ( n-k+2 )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_csptrs

     pure module subroutine stdlib${ii}$_zsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
     !! ZSPTRS solves a system of linear equations A*X = B with a complex
     !! symmetric matrix A stored in packed format using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(dp), intent(in) :: ap(*)
           complex(dp), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kp
           complex(dp) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'ZSPTRS', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              kc = kc - k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_zgeru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_zscal( nrhs, cone / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k-1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 call stdlib${ii}$_zgeru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 call stdlib${ii}$_zgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, &
                           1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+k-2 )
                 akm1 = ap( kc-1 ) / akm1k
                 ak = ap( kc+k-1 ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc - k + 1_${ik}$
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
                            1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + k
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
                            1_${ik}$ ), ldb )
                 call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1_${ik}$, cone, b( &
                           k+1, 1_${ik}$ ), ldb )
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + 2_${ik}$*k + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_zgeru( n-k, nrhs, -cone, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
                           1_${ik}$, 1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_zscal( nrhs, cone / ap( kc ), b( k, 1_${ik}$ ), ldb )
                 kc = kc + n - k + 1_${ik}$
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k+1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k+1 )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_zgeru( n-k-1, nrhs, -cone, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
                              1_${ik}$ ), ldb )
                    call stdlib${ii}$_zgeru( n-k-1, nrhs, -cone, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
                              k+2, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+1 )
                 akm1 = ap( kc ) / akm1k
                 ak = ap( kc+n-k+1 ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              kc = kc - ( n-k+1 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( &
                           kc+1 ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ),&
                               1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
                              k ) ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc - ( n-k+2 )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_zsptrs

#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ci}$sptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
     !! ZSPTRS: solves a system of linear equations A*X = B with a complex
     !! symmetric matrix A stored in packed format using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(${ck}$), intent(in) :: ap(*)
           complex(${ck}$), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kp
           complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'ZSPTRS', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              kc = kc - k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_${ci}$scal( nrhs, cone / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k-1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, &
                           1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+k-2 )
                 akm1 = ap( kc-1 ) / akm1k
                 ak = ap( kc+k-1 ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc - k + 1_${ik}$
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
                            1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + k
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,&
                            1_${ik}$ ), ldb )
                 call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1_${ik}$, cone, b( &
                           k+1, 1_${ik}$ ), ldb )
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc + 2_${ik}$*k + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_${ci}$geru( n-k, nrhs, -cone, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
                           1_${ik}$, 1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_${ci}$scal( nrhs, cone / ap( kc ), b( k, 1_${ik}$ ), ldb )
                 kc = kc + n - k + 1_${ik}$
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k+1 and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k+1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_${ci}$geru( n-k-1, nrhs, -cone, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
                              1_${ik}$ ), ldb )
                    call stdlib${ii}$_${ci}$geru( n-k-1, nrhs, -cone, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
                              k+2, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = ap( kc+1 )
                 akm1 = ap( kc ) / akm1k
                 ak = ap( kc+n-k+1 ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              kc = kc - ( n-k+1 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( &
                           kc+1 ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc+1 ),&
                               1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, ap( kc-( n-&
                              k ) ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kc = kc - ( n-k+2 )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_${ci}$sptrs

#:endif
#:endfor



     pure module subroutine stdlib${ii}$_ssptri( uplo, n, ap, ipiv, work, info )
     !! SSPTRI computes the inverse of a real symmetric indefinite matrix
     !! A in packed storage using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by SSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(sp), intent(inout) :: ap(*)
           real(sp), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
           real(sp) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'SSPTRI', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              kp = n*( n+1 ) / 2_${ik}$
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. ap( kp )==zero )return
                 kp = kp - info
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              kp = 1_${ik}$
              do info = 1, n
                 if( ipiv( info )>0 .and. ap( kp )==zero )return
                 kp = kp + n - info + 1_${ik}$
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              kcnext = kc + k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc+k-1 ) = one / ap( kc+k-1 )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_scopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_sspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( ap( kcnext+k-1 ) )
                 ak = ap( kc+k-1 ) / t
                 akp1 = ap( kcnext+k ) / t
                 akkp1 = ap( kcnext+k-1 ) / t
                 d = t*( ak*akp1-one )
                 ap( kc+k-1 ) = akp1 / d
                 ap( kcnext+k ) = ak / d
                 ap( kcnext+k-1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_scopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_sspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                    ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_sdot( k-1, ap( kc ), 1_${ik}$, ap( &
                              kcnext ),1_${ik}$ )
                    call stdlib${ii}$_scopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_sspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero,ap( kcnext ), 1_${ik}$ )
                              
                    ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext + k + 1_${ik}$
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
                 call stdlib${ii}$_sswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
                 kx = kpc + kp - 1_${ik}$
                 do j = kp + 1, k - 1
                    kx = kx + j - 1_${ik}$
                    temp = ap( kc+j-1 )
                    ap( kc+j-1 ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc+k-1 )
                 ap( kc+k-1 ) = ap( kpc+kp-1 )
                 ap( kpc+kp-1 ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc+k+k-1 )
                    ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
                    ap( kc+k+kp-1 ) = temp
                 end if
              end if
              k = k + kstep
              kc = kcnext
              go to 30
              50 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              npp = n*( n+1 ) / 2_${ik}$
              k = n
              kc = npp
              60 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 80
              kcnext = kc - ( n-k+2 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc ) = one / ap( kc )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_scopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_sspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1_${ik}$,zero, ap( kc+1 ), &
                              1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_sdot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( ap( kcnext+1 ) )
                 ak = ap( kcnext ) / t
                 akp1 = ap( kc ) / t
                 akkp1 = ap( kcnext+1 ) / t
                 d = t*( ak*akp1-one )
                 ap( kcnext ) = akp1 / d
                 ap( kc ) = ak / d
                 ap( kcnext+1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_scopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_sspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( kc+&
                              1_${ik}$ ), 1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_sdot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
                    ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_sdot( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+2 &
                              ), 1_${ik}$ )
                    call stdlib${ii}$_scopy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_sspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( &
                              kcnext+2 ), 1_${ik}$ )
                    ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_sdot( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext - ( n-k+3 )
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
                 if( kp<n )call stdlib${ii}$_sswap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
                 kx = kc + kp - k
                 do j = k + 1, kp - 1
                    kx = kx + n - j + 1_${ik}$
                    temp = ap( kc+j-k )
                    ap( kc+j-k ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc )
                 ap( kc ) = ap( kpc )
                 ap( kpc ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc-n+k-1 )
                    ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
                    ap( kc-n+kp-1 ) = temp
                 end if
              end if
              k = k - kstep
              kc = kcnext
              go to 60
              80 continue
           end if
           return
     end subroutine stdlib${ii}$_ssptri

     pure module subroutine stdlib${ii}$_dsptri( uplo, n, ap, ipiv, work, info )
     !! DSPTRI computes the inverse of a real symmetric indefinite matrix
     !! A in packed storage using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by DSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(dp), intent(inout) :: ap(*)
           real(dp), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
           real(dp) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'DSPTRI', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              kp = n*( n+1 ) / 2_${ik}$
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. ap( kp )==zero )return
                 kp = kp - info
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              kp = 1_${ik}$
              do info = 1, n
                 if( ipiv( info )>0 .and. ap( kp )==zero )return
                 kp = kp + n - info + 1_${ik}$
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              kcnext = kc + k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc+k-1 ) = one / ap( kc+k-1 )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_dcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( ap( kcnext+k-1 ) )
                 ak = ap( kc+k-1 ) / t
                 akp1 = ap( kcnext+k ) / t
                 akkp1 = ap( kcnext+k-1 ) / t
                 d = t*( ak*akp1-one )
                 ap( kc+k-1 ) = akp1 / d
                 ap( kcnext+k ) = ak / d
                 ap( kcnext+k-1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_dcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                    ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_ddot( k-1, ap( kc ), 1_${ik}$, ap( &
                              kcnext ),1_${ik}$ )
                    call stdlib${ii}$_dcopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero,ap( kcnext ), 1_${ik}$ )
                              
                    ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext + k + 1_${ik}$
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
                 call stdlib${ii}$_dswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
                 kx = kpc + kp - 1_${ik}$
                 do j = kp + 1, k - 1
                    kx = kx + j - 1_${ik}$
                    temp = ap( kc+j-1 )
                    ap( kc+j-1 ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc+k-1 )
                 ap( kc+k-1 ) = ap( kpc+kp-1 )
                 ap( kpc+kp-1 ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc+k+k-1 )
                    ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
                    ap( kc+k+kp-1 ) = temp
                 end if
              end if
              k = k + kstep
              kc = kcnext
              go to 30
              50 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              npp = n*( n+1 ) / 2_${ik}$
              k = n
              kc = npp
              60 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 80
              kcnext = kc - ( n-k+2 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc ) = one / ap( kc )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_dcopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1_${ik}$,zero, ap( kc+1 ), &
                              1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_ddot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( ap( kcnext+1 ) )
                 ak = ap( kcnext ) / t
                 akp1 = ap( kc ) / t
                 akkp1 = ap( kcnext+1 ) / t
                 d = t*( ak*akp1-one )
                 ap( kcnext ) = akp1 / d
                 ap( kc ) = ak / d
                 ap( kcnext+1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_dcopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( kc+&
                              1_${ik}$ ), 1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_ddot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
                    ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_ddot( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+2 &
                              ), 1_${ik}$ )
                    call stdlib${ii}$_dcopy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( &
                              kcnext+2 ), 1_${ik}$ )
                    ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_ddot( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext - ( n-k+3 )
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
                 if( kp<n )call stdlib${ii}$_dswap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
                 kx = kc + kp - k
                 do j = k + 1, kp - 1
                    kx = kx + n - j + 1_${ik}$
                    temp = ap( kc+j-k )
                    ap( kc+j-k ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc )
                 ap( kc ) = ap( kpc )
                 ap( kpc ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc-n+k-1 )
                    ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
                    ap( kc-n+kp-1 ) = temp
                 end if
              end if
              k = k - kstep
              kc = kcnext
              go to 60
              80 continue
           end if
           return
     end subroutine stdlib${ii}$_dsptri

#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ri}$sptri( uplo, n, ap, ipiv, work, info )
     !! DSPTRI: computes the inverse of a real symmetric indefinite matrix
     !! A in packed storage using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by DSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(${rk}$), intent(inout) :: ap(*)
           real(${rk}$), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
           real(${rk}$) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'DSPTRI', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              kp = n*( n+1 ) / 2_${ik}$
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. ap( kp )==zero )return
                 kp = kp - info
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              kp = 1_${ik}$
              do info = 1, n
                 if( ipiv( info )>0 .and. ap( kp )==zero )return
                 kp = kp + n - info + 1_${ik}$
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              kcnext = kc + k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc+k-1 ) = one / ap( kc+k-1 )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_${ri}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$spmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( ap( kcnext+k-1 ) )
                 ak = ap( kc+k-1 ) / t
                 akp1 = ap( kcnext+k ) / t
                 akkp1 = ap( kcnext+k-1 ) / t
                 d = t*( ak*akp1-one )
                 ap( kc+k-1 ) = akp1 / d
                 ap( kcnext+k ) = ak / d
                 ap( kcnext+k-1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_${ri}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$spmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                    ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_${ri}$dot( k-1, ap( kc ), 1_${ik}$, ap( &
                              kcnext ),1_${ik}$ )
                    call stdlib${ii}$_${ri}$copy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$spmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero,ap( kcnext ), 1_${ik}$ )
                              
                    ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext + k + 1_${ik}$
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
                 call stdlib${ii}$_${ri}$swap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
                 kx = kpc + kp - 1_${ik}$
                 do j = kp + 1, k - 1
                    kx = kx + j - 1_${ik}$
                    temp = ap( kc+j-1 )
                    ap( kc+j-1 ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc+k-1 )
                 ap( kc+k-1 ) = ap( kpc+kp-1 )
                 ap( kpc+kp-1 ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc+k+k-1 )
                    ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
                    ap( kc+k+kp-1 ) = temp
                 end if
              end if
              k = k + kstep
              kc = kcnext
              go to 30
              50 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              npp = n*( n+1 ) / 2_${ik}$
              k = n
              kc = npp
              60 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 80
              kcnext = kc - ( n-k+2 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc ) = one / ap( kc )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_${ri}$copy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$spmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1_${ik}$,zero, ap( kc+1 ), &
                              1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( ap( kcnext+1 ) )
                 ak = ap( kcnext ) / t
                 akp1 = ap( kc ) / t
                 akkp1 = ap( kcnext+1 ) / t
                 d = t*( ak*akp1-one )
                 ap( kcnext ) = akp1 / d
                 ap( kc ) = ak / d
                 ap( kcnext+1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_${ri}$copy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$spmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( kc+&
                              1_${ik}$ ), 1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, ap( kc+1 ), 1_${ik}$ )
                    ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_${ri}$dot( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+2 &
                              ), 1_${ik}$ )
                    call stdlib${ii}$_${ri}$copy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$spmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1_${ik}$,zero, ap( &
                              kcnext+2 ), 1_${ik}$ )
                    ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext - ( n-k+3 )
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
                 if( kp<n )call stdlib${ii}$_${ri}$swap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
                 kx = kc + kp - k
                 do j = k + 1, kp - 1
                    kx = kx + n - j + 1_${ik}$
                    temp = ap( kc+j-k )
                    ap( kc+j-k ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc )
                 ap( kc ) = ap( kpc )
                 ap( kpc ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc-n+k-1 )
                    ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
                    ap( kc-n+kp-1 ) = temp
                 end if
              end if
              k = k - kstep
              kc = kcnext
              go to 60
              80 continue
           end if
           return
     end subroutine stdlib${ii}$_${ri}$sptri

#:endif
#:endfor

     pure module subroutine stdlib${ii}$_csptri( uplo, n, ap, ipiv, work, info )
     !! CSPTRI computes the inverse of a complex symmetric indefinite matrix
     !! A in packed storage using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by CSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(sp), intent(inout) :: ap(*)
           complex(sp), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
           complex(sp) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'CSPTRI', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              kp = n*( n+1 ) / 2_${ik}$
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. ap( kp )==czero )return
                 kp = kp - info
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              kp = 1_${ik}$
              do info = 1, n
                 if( ipiv( info )>0 .and. ap( kp )==czero )return
                 kp = kp + n - info + 1_${ik}$
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              kcnext = kc + k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc+k-1 ) = cone / ap( kc+k-1 )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_ccopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_cspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = ap( kcnext+k-1 )
                 ak = ap( kc+k-1 ) / t
                 akp1 = ap( kcnext+k ) / t
                 akkp1 = ap( kcnext+k-1 ) / t
                 d = t*( ak*akp1-cone )
                 ap( kc+k-1 ) = akp1 / d
                 ap( kcnext+k ) = ak / d
                 ap( kcnext+k-1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_ccopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_cspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                    ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_cdotu( k-1, ap( kc ), 1_${ik}$, ap( &
                              kcnext ),1_${ik}$ )
                    call stdlib${ii}$_ccopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_cspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ )
                              
                    ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext + k + 1_${ik}$
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
                 call stdlib${ii}$_cswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
                 kx = kpc + kp - 1_${ik}$
                 do j = kp + 1, k - 1
                    kx = kx + j - 1_${ik}$
                    temp = ap( kc+j-1 )
                    ap( kc+j-1 ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc+k-1 )
                 ap( kc+k-1 ) = ap( kpc+kp-1 )
                 ap( kpc+kp-1 ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc+k+k-1 )
                    ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
                    ap( kc+k+kp-1 ) = temp
                 end if
              end if
              k = k + kstep
              kc = kcnext
              go to 30
              50 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              npp = n*( n+1 ) / 2_${ik}$
              k = n
              kc = npp
              60 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 80
              kcnext = kc - ( n-k+2 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc ) = cone / ap( kc )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_ccopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_cspmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1_${ik}$,czero, ap( kc+1 )&
                              , 1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = ap( kcnext+1 )
                 ak = ap( kcnext ) / t
                 akp1 = ap( kc ) / t
                 akkp1 = ap( kcnext+1 ) / t
                 d = t*( ak*akp1-cone )
                 ap( kcnext ) = akp1 / d
                 ap( kc ) = ak / d
                 ap( kcnext+1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_ccopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_cspmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
                              kc+1 ), 1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
                    ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_cdotu( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+&
                              2_${ik}$ ), 1_${ik}$ )
                    call stdlib${ii}$_ccopy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_cspmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
                              kcnext+2 ), 1_${ik}$ )
                    ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext - ( n-k+3 )
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
                 if( kp<n )call stdlib${ii}$_cswap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
                 kx = kc + kp - k
                 do j = k + 1, kp - 1
                    kx = kx + n - j + 1_${ik}$
                    temp = ap( kc+j-k )
                    ap( kc+j-k ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc )
                 ap( kc ) = ap( kpc )
                 ap( kpc ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc-n+k-1 )
                    ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
                    ap( kc-n+kp-1 ) = temp
                 end if
              end if
              k = k - kstep
              kc = kcnext
              go to 60
              80 continue
           end if
           return
     end subroutine stdlib${ii}$_csptri

     pure module subroutine stdlib${ii}$_zsptri( uplo, n, ap, ipiv, work, info )
     !! ZSPTRI computes the inverse of a complex symmetric indefinite matrix
     !! A in packed storage using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by ZSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(dp), intent(inout) :: ap(*)
           complex(dp), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
           complex(dp) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'ZSPTRI', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              kp = n*( n+1 ) / 2_${ik}$
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. ap( kp )==czero )return
                 kp = kp - info
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              kp = 1_${ik}$
              do info = 1, n
                 if( ipiv( info )>0 .and. ap( kp )==czero )return
                 kp = kp + n - info + 1_${ik}$
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              kcnext = kc + k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc+k-1 ) = cone / ap( kc+k-1 )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_zcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = ap( kcnext+k-1 )
                 ak = ap( kc+k-1 ) / t
                 akp1 = ap( kcnext+k ) / t
                 akkp1 = ap( kcnext+k-1 ) / t
                 d = t*( ak*akp1-cone )
                 ap( kc+k-1 ) = akp1 / d
                 ap( kcnext+k ) = ak / d
                 ap( kcnext+k-1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_zcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                    ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_zdotu( k-1, ap( kc ), 1_${ik}$, ap( &
                              kcnext ),1_${ik}$ )
                    call stdlib${ii}$_zcopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ )
                              
                    ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext + k + 1_${ik}$
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
                 call stdlib${ii}$_zswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
                 kx = kpc + kp - 1_${ik}$
                 do j = kp + 1, k - 1
                    kx = kx + j - 1_${ik}$
                    temp = ap( kc+j-1 )
                    ap( kc+j-1 ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc+k-1 )
                 ap( kc+k-1 ) = ap( kpc+kp-1 )
                 ap( kpc+kp-1 ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc+k+k-1 )
                    ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
                    ap( kc+k+kp-1 ) = temp
                 end if
              end if
              k = k + kstep
              kc = kcnext
              go to 30
              50 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              npp = n*( n+1 ) / 2_${ik}$
              k = n
              kc = npp
              60 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 80
              kcnext = kc - ( n-k+2 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc ) = cone / ap( kc )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_zcopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zspmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1_${ik}$,czero, ap( kc+1 )&
                              , 1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = ap( kcnext+1 )
                 ak = ap( kcnext ) / t
                 akp1 = ap( kc ) / t
                 akkp1 = ap( kcnext+1 ) / t
                 d = t*( ak*akp1-cone )
                 ap( kcnext ) = akp1 / d
                 ap( kc ) = ak / d
                 ap( kcnext+1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_zcopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zspmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
                              kc+1 ), 1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
                    ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_zdotu( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+&
                              2_${ik}$ ), 1_${ik}$ )
                    call stdlib${ii}$_zcopy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zspmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
                              kcnext+2 ), 1_${ik}$ )
                    ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext - ( n-k+3 )
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
                 if( kp<n )call stdlib${ii}$_zswap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
                 kx = kc + kp - k
                 do j = k + 1, kp - 1
                    kx = kx + n - j + 1_${ik}$
                    temp = ap( kc+j-k )
                    ap( kc+j-k ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc )
                 ap( kc ) = ap( kpc )
                 ap( kpc ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc-n+k-1 )
                    ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
                    ap( kc-n+kp-1 ) = temp
                 end if
              end if
              k = k - kstep
              kc = kcnext
              go to 60
              80 continue
           end if
           return
     end subroutine stdlib${ii}$_zsptri

#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ci}$sptri( uplo, n, ap, ipiv, work, info )
     !! ZSPTRI: computes the inverse of a complex symmetric indefinite matrix
     !! A in packed storage using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by ZSPTRF.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(${ck}$), intent(inout) :: ap(*)
           complex(${ck}$), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
           complex(${ck}$) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'ZSPTRI', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              kp = n*( n+1 ) / 2_${ik}$
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. ap( kp )==czero )return
                 kp = kp - info
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              kp = 1_${ik}$
              do info = 1, n
                 if( ipiv( info )>0 .and. ap( kp )==czero )return
                 kp = kp + n - info + 1_${ik}$
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              kc = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              kcnext = kc + k
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc+k-1 ) = cone / ap( kc+k-1 )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_${ci}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$spmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = ap( kcnext+k-1 )
                 ak = ap( kc+k-1 ) / t
                 akp1 = ap( kcnext+k ) / t
                 akkp1 = ap( kcnext+k-1 ) / t
                 d = t*( ak*akp1-cone )
                 ap( kc+k-1 ) = akp1 / d
                 ap( kcnext+k ) = ak / d
                 ap( kcnext+k-1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_${ci}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$spmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ )
                    ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ )
                    ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_${ci}$dotu( k-1, ap( kc ), 1_${ik}$, ap( &
                              kcnext ),1_${ik}$ )
                    call stdlib${ii}$_${ci}$copy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$spmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ )
                              
                    ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext + k + 1_${ik}$
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
                 call stdlib${ii}$_${ci}$swap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
                 kx = kpc + kp - 1_${ik}$
                 do j = kp + 1, k - 1
                    kx = kx + j - 1_${ik}$
                    temp = ap( kc+j-1 )
                    ap( kc+j-1 ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc+k-1 )
                 ap( kc+k-1 ) = ap( kpc+kp-1 )
                 ap( kpc+kp-1 ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc+k+k-1 )
                    ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
                    ap( kc+k+kp-1 ) = temp
                 end if
              end if
              k = k + kstep
              kc = kcnext
              go to 30
              50 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              npp = n*( n+1 ) / 2_${ik}$
              k = n
              kc = npp
              60 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 80
              kcnext = kc - ( n-k+2 )
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 ap( kc ) = cone / ap( kc )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_${ci}$copy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$spmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1_${ik}$,czero, ap( kc+1 )&
                              , 1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = ap( kcnext+1 )
                 ak = ap( kcnext ) / t
                 akp1 = ap( kc ) / t
                 akkp1 = ap( kcnext+1 ) / t
                 d = t*( ak*akp1-cone )
                 ap( kcnext ) = akp1 / d
                 ap( kc ) = ak / d
                 ap( kcnext+1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_${ci}$copy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$spmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
                              kc+1 ), 1_${ik}$ )
                    ap( kc ) = ap( kc ) - stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, ap( kc+1 ),1_${ik}$ )
                    ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_${ci}$dotu( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+&
                              2_${ik}$ ), 1_${ik}$ )
                    call stdlib${ii}$_${ci}$copy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$spmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work, 1_${ik}$,czero, ap( &
                              kcnext+2 ), 1_${ik}$ )
                    ap( kcnext ) = ap( kcnext ) -stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, ap( kcnext+2 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
                 kcnext = kcnext - ( n-k+3 )
              end if
              kp = abs( ipiv( k ) )
              if( kp/=k ) then
                 ! interchange rows and columns k and kp in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
                 if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
                 kx = kc + kp - k
                 do j = k + 1, kp - 1
                    kx = kx + n - j + 1_${ik}$
                    temp = ap( kc+j-k )
                    ap( kc+j-k ) = ap( kx )
                    ap( kx ) = temp
                 end do
                 temp = ap( kc )
                 ap( kc ) = ap( kpc )
                 ap( kpc ) = temp
                 if( kstep==2_${ik}$ ) then
                    temp = ap( kc-n+k-1 )
                    ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
                    ap( kc-n+kp-1 ) = temp
                 end if
              end if
              k = k - kstep
              kc = kcnext
              go to 60
              80 continue
           end if
           return
     end subroutine stdlib${ii}$_${ci}$sptri

#:endif
#:endfor



     pure module subroutine stdlib${ii}$_ssprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
     !! SSPRFS improves the computed solution to a system of linear
     !! equations when the coefficient matrix is symmetric indefinite
     !! 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(in) :: ipiv(*)
           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 = -8_${ik}$
           else if( ldx<max( 1_${ik}$, n ) ) then
              info = -10_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'SSPRFS', -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}$_ssptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$_ssptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$_ssptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$_ssprfs

     pure module subroutine stdlib${ii}$_dsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
     !! DSPRFS improves the computed solution to a system of linear
     !! equations when the coefficient matrix is symmetric indefinite
     !! 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(in) :: ipiv(*)
           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 = -8_${ik}$
           else if( ldx<max( 1_${ik}$, n ) ) then
              info = -10_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSPRFS', -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}$_dsptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$_dsptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$_dsptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$_dsprfs

#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ri}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
     !! DSPRFS: improves the computed solution to a system of linear
     !! equations when the coefficient matrix is symmetric indefinite
     !! 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(in) :: ipiv(*)
           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 = -8_${ik}$
           else if( ldx<max( 1_${ik}$, n ) ) then
              info = -10_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSPRFS', -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}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$sprfs

#:endif
#:endfor

     pure module subroutine stdlib${ii}$_csprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
     !! CSPRFS improves the computed solution to a system of linear
     !! equations when the coefficient matrix is symmetric indefinite
     !! 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           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 = -8_${ik}$
           else if( ldx<max( 1_${ik}$, n ) ) then
              info = -10_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'CSPRFS', -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}$_cspmv( 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 ) + cabs1( ap( kk+k-1 ) )*xk + s
                    kk = kk + k
                 end do
              else
                 do k = 1, n
                    s = zero
                    xk = cabs1( x( k, j ) )
                    rwork( k ) = rwork( k ) + cabs1( ap( kk ) )*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}$_csptrs( uplo, n, 1_${ik}$, afp, ipiv, 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**t).
                    call stdlib${ii}$_csptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$_csptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$_csprfs

     pure module subroutine stdlib${ii}$_zsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
     !! ZSPRFS improves the computed solution to a system of linear
     !! equations when the coefficient matrix is symmetric indefinite
     !! 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           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 = -8_${ik}$
           else if( ldx<max( 1_${ik}$, n ) ) then
              info = -10_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'ZSPRFS', -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}$_zspmv( 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 ) + cabs1( ap( kk+k-1 ) )*xk + s
                    kk = kk + k
                 end do
              else
                 do k = 1, n
                    s = zero
                    xk = cabs1( x( k, j ) )
                    rwork( k ) = rwork( k ) + cabs1( ap( kk ) )*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}$_zsptrs( uplo, n, 1_${ik}$, afp, ipiv, 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**t).
                    call stdlib${ii}$_zsptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$_zsptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$_zsprfs

#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ci}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,&
     !! ZSPRFS: improves the computed solution to a system of linear
     !! equations when the coefficient matrix is symmetric indefinite
     !! 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           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 = -8_${ik}$
           else if( ldx<max( 1_${ik}$, n ) ) then
              info = -10_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'ZSPRFS', -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}$spmv( 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 ) + cabs1( ap( kk+k-1 ) )*xk + s
                    kk = kk + k
                 end do
              else
                 do k = 1, n
                    s = zero
                    xk = cabs1( x( k, j ) )
                    rwork( k ) = rwork( k ) + cabs1( ap( kk ) )*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}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, 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**t).
                    call stdlib${ii}$_${ci}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, 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}$sprfs

#:endif
#:endfor



     pure module subroutine stdlib${ii}$_ssycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info )
     !! SSYCON_ROOK estimates the reciprocal of the condition number (in the
     !! 1-norm) of a real symmetric matrix A using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by SSYTRF_ROOK.
     !! 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(in) :: ipiv(*)
           integer(${ik}$), intent(out) :: iwork(*)
           real(sp), intent(in) :: a(lda,*)
           real(sp), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: i, kase
           real(sp) :: ainvnm
           ! 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 = -6_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'SSYCON_ROOK', -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
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do i = n, 1, -1
                 if( ipiv( i )>0 .and. a( i, i )==zero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do i = 1, n
                 if( ipiv( i )>0 .and. a( i, i )==zero )return
              end do
           end if
           ! estimate the 1-norm of the inverse.
           kase = 0_${ik}$
           30 continue
           call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
           if( kase/=0_${ik}$ ) then
              ! multiply by inv(l*d*l**t) or inv(u*d*u**t).
              call stdlib${ii}$_ssytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
              go to 30
           end if
           ! compute the estimate of the reciprocal condition number.
           if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
           return
     end subroutine stdlib${ii}$_ssycon_rook

     pure module subroutine stdlib${ii}$_dsycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info )
     !! DSYCON_ROOK estimates the reciprocal of the condition number (in the
     !! 1-norm) of a real symmetric matrix A using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by DSYTRF_ROOK.
     !! 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(in) :: ipiv(*)
           integer(${ik}$), intent(out) :: iwork(*)
           real(dp), intent(in) :: a(lda,*)
           real(dp), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: i, kase
           real(dp) :: ainvnm
           ! 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 = -6_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSYCON_ROOK', -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
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do i = n, 1, -1
                 if( ipiv( i )>0 .and. a( i, i )==zero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do i = 1, n
                 if( ipiv( i )>0 .and. a( i, i )==zero )return
              end do
           end if
           ! estimate the 1-norm of the inverse.
           kase = 0_${ik}$
           30 continue
           call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
           if( kase/=0_${ik}$ ) then
              ! multiply by inv(l*d*l**t) or inv(u*d*u**t).
              call stdlib${ii}$_dsytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
              go to 30
           end if
           ! compute the estimate of the reciprocal condition number.
           if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
           return
     end subroutine stdlib${ii}$_dsycon_rook

#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ri}$sycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info )
     !! DSYCON_ROOK: estimates the reciprocal of the condition number (in the
     !! 1-norm) of a real symmetric matrix A using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by DSYTRF_ROOK.
     !! 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(in) :: ipiv(*)
           integer(${ik}$), intent(out) :: iwork(*)
           real(${rk}$), intent(in) :: a(lda,*)
           real(${rk}$), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: i, kase
           real(${rk}$) :: ainvnm
           ! 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 = -6_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSYCON_ROOK', -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
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do i = n, 1, -1
                 if( ipiv( i )>0 .and. a( i, i )==zero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do i = 1, n
                 if( ipiv( i )>0 .and. a( i, i )==zero )return
              end do
           end if
           ! estimate the 1-norm of the inverse.
           kase = 0_${ik}$
           30 continue
           call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
           if( kase/=0_${ik}$ ) then
              ! multiply by inv(l*d*l**t) or inv(u*d*u**t).
              call stdlib${ii}$_${ri}$sytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
              go to 30
           end if
           ! compute the estimate of the reciprocal condition number.
           if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
           return
     end subroutine stdlib${ii}$_${ri}$sycon_rook

#:endif
#:endfor

     pure module subroutine stdlib${ii}$_csycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
     !! CSYCON_ROOK estimates the reciprocal of the condition number (in the
     !! 1-norm) of a complex symmetric matrix A using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by CSYTRF_ROOK.
     !! 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(in) :: ipiv(*)
           complex(sp), intent(in) :: a(lda,*)
           complex(sp), intent(out) :: work(*)
        ! =====================================================================
           
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: i, kase
           real(sp) :: ainvnm
           ! 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 = -6_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'CSYCON_ROOK', -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
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do i = n, 1, -1
                 if( ipiv( i )>0 .and. a( i, i )==czero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do i = 1, n
                 if( ipiv( i )>0 .and. a( i, i )==czero )return
              end do
           end if
           ! estimate the 1-norm of the inverse.
           kase = 0_${ik}$
           30 continue
           call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
           if( kase/=0_${ik}$ ) then
              ! multiply by inv(l*d*l**t) or inv(u*d*u**t).
              call stdlib${ii}$_csytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
              go to 30
           end if
           ! compute the estimate of the reciprocal condition number.
           if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
           return
     end subroutine stdlib${ii}$_csycon_rook

     pure module subroutine stdlib${ii}$_zsycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
     !! ZSYCON_ROOK estimates the reciprocal of the condition number (in the
     !! 1-norm) of a complex symmetric matrix A using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by ZSYTRF_ROOK.
     !! 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(in) :: ipiv(*)
           complex(dp), intent(in) :: a(lda,*)
           complex(dp), intent(out) :: work(*)
        ! =====================================================================
           
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: i, kase
           real(dp) :: ainvnm
           ! 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 = -6_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'ZSYCON_ROOK', -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
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do i = n, 1, -1
                 if( ipiv( i )>0 .and. a( i, i )==czero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do i = 1, n
                 if( ipiv( i )>0 .and. a( i, i )==czero )return
              end do
           end if
           ! estimate the 1-norm of the inverse.
           kase = 0_${ik}$
           30 continue
           call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
           if( kase/=0_${ik}$ ) then
              ! multiply by inv(l*d*l**t) or inv(u*d*u**t).
              call stdlib${ii}$_zsytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
              go to 30
           end if
           ! compute the estimate of the reciprocal condition number.
           if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
           return
     end subroutine stdlib${ii}$_zsycon_rook

#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ci}$sycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
     !! ZSYCON_ROOK: estimates the reciprocal of the condition number (in the
     !! 1-norm) of a complex symmetric matrix A using the factorization
     !! A = U*D*U**T or A = L*D*L**T computed by ZSYTRF_ROOK.
     !! 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(${ck}$), intent(in) :: a(lda,*)
           complex(${ck}$), intent(out) :: work(*)
        ! =====================================================================
           
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: i, kase
           real(${ck}$) :: ainvnm
           ! 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 = -6_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'ZSYCON_ROOK', -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
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do i = n, 1, -1
                 if( ipiv( i )>0 .and. a( i, i )==czero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do i = 1, n
                 if( ipiv( i )>0 .and. a( i, i )==czero )return
              end do
           end if
           ! estimate the 1-norm of the inverse.
           kase = 0_${ik}$
           30 continue
           call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
           if( kase/=0_${ik}$ ) then
              ! multiply by inv(l*d*l**t) or inv(u*d*u**t).
              call stdlib${ii}$_${ci}$sytrs_rook( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
              go to 30
           end if
           ! compute the estimate of the reciprocal condition number.
           if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
           return
     end subroutine stdlib${ii}$_${ci}$sycon_rook

#:endif
#:endfor



     pure module subroutine stdlib${ii}$_ssytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
     !! SSYTRF_ROOK computes the factorization of a real symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
     !! The form of the factorization is
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, and D is symmetric and block diagonal with
     !! 1-by-1 and 2-by-2 diagonal blocks.
     !! This is the blocked 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, lwork, n
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(sp), intent(inout) :: a(lda,*)
           real(sp), intent(out) :: work(*)
        ! =====================================================================
           ! Local Scalars 
           logical(lk) :: lquery, upper
           integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
           ! Intrinsic Functions 
           ! Executable Statements 
           ! test the input parameters.
           info = 0_${ik}$
           upper = stdlib_lsame( uplo, 'U' )
           lquery = ( lwork==-1_${ik}$ )
           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( lwork<1_${ik}$ .and. .not.lquery ) then
              info = -7_${ik}$
           end if
           if( info==0_${ik}$ ) then
              ! determine the block size
              nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
              lwkopt = max( 1_${ik}$, n*nb )
              work( 1_${ik}$ ) = lwkopt
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'SSYTRF_ROOK', -info )
              return
           else if( lquery ) then
              return
           end if
           nbmin = 2_${ik}$
           ldwork = n
           if( nb>1_${ik}$ .and. nb<n ) then
              iws = ldwork*nb
              if( lwork<iws ) then
                 nb = max( lwork / ldwork, 1_${ik}$ )
                 nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
              end if
           else
              iws = 1_${ik}$
           end if
           if( nb<nbmin )nb = n
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf_rook;
              ! kb is either nb or nb-1, or k for the last block
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 40
              if( k>nb ) then
                 ! factorize columns k-kb+1:k of a and use blocked code to
                 ! update columns 1:k-kb
                 call stdlib${ii}$_slasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
                           
              else
                 ! use unblocked code to factorize columns 1:k of a
                 call stdlib${ii}$_ssytf2_rook( uplo, k, a, lda, ipiv, iinfo )
                 kb = k
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
              ! no need to adjust ipiv
              ! decrease k and return to the start of the main loop
              k = k - kb
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf_rook;
              ! kb is either nb or nb-1, or n-k+1 for the last block
              k = 1_${ik}$
              20 continue
              ! if k > n, exit from loop
              if( k>n )go to 40
              if( k<=n-nb ) then
                 ! factorize columns k:k+kb-1 of a and use blocked code to
                 ! update columns k+kb:n
                 call stdlib${ii}$_slasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
                           ldwork, iinfo )
              else
                 ! use unblocked code to factorize columns k:n of a
                 call stdlib${ii}$_ssytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
                 kb = n - k + 1_${ik}$
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
              ! adjust ipiv
              do j = k, k + kb - 1
                 if( ipiv( j )>0_${ik}$ ) then
                    ipiv( j ) = ipiv( j ) + k - 1_${ik}$
                 else
                    ipiv( j ) = ipiv( j ) - k + 1_${ik}$
                 end if
              end do
              ! increase k and return to the start of the main loop
              k = k + kb
              go to 20
           end if
           40 continue
           work( 1_${ik}$ ) = lwkopt
           return
     end subroutine stdlib${ii}$_ssytrf_rook

     pure module subroutine stdlib${ii}$_dsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
     !! DSYTRF_ROOK computes the factorization of a real symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
     !! The form of the factorization is
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, and D is symmetric and block diagonal with
     !! 1-by-1 and 2-by-2 diagonal blocks.
     !! This is the blocked 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, lwork, n
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(dp), intent(inout) :: a(lda,*)
           real(dp), intent(out) :: work(*)
        ! =====================================================================
           ! Local Scalars 
           logical(lk) :: lquery, upper
           integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
           ! Intrinsic Functions 
           ! Executable Statements 
           ! test the input parameters.
           info = 0_${ik}$
           upper = stdlib_lsame( uplo, 'U' )
           lquery = ( lwork==-1_${ik}$ )
           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( lwork<1_${ik}$ .and. .not.lquery ) then
              info = -7_${ik}$
           end if
           if( info==0_${ik}$ ) then
              ! determine the block size
              nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
              lwkopt = max( 1_${ik}$, n*nb )
              work( 1_${ik}$ ) = lwkopt
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSYTRF_ROOK', -info )
              return
           else if( lquery ) then
              return
           end if
           nbmin = 2_${ik}$
           ldwork = n
           if( nb>1_${ik}$ .and. nb<n ) then
              iws = ldwork*nb
              if( lwork<iws ) then
                 nb = max( lwork / ldwork, 1_${ik}$ )
                 nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
              end if
           else
              iws = 1_${ik}$
           end if
           if( nb<nbmin )nb = n
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf_rook;
              ! kb is either nb or nb-1, or k for the last block
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 40
              if( k>nb ) then
                 ! factorize columns k-kb+1:k of a and use blocked code to
                 ! update columns 1:k-kb
                 call stdlib${ii}$_dlasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
                           
              else
                 ! use unblocked code to factorize columns 1:k of a
                 call stdlib${ii}$_dsytf2_rook( uplo, k, a, lda, ipiv, iinfo )
                 kb = k
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
              ! no need to adjust ipiv
              ! decrease k and return to the start of the main loop
              k = k - kb
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf_rook;
              ! kb is either nb or nb-1, or n-k+1 for the last block
              k = 1_${ik}$
              20 continue
              ! if k > n, exit from loop
              if( k>n )go to 40
              if( k<=n-nb ) then
                 ! factorize columns k:k+kb-1 of a and use blocked code to
                 ! update columns k+kb:n
                 call stdlib${ii}$_dlasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
                           ldwork, iinfo )
              else
                 ! use unblocked code to factorize columns k:n of a
                 call stdlib${ii}$_dsytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
                 kb = n - k + 1_${ik}$
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
              ! adjust ipiv
              do j = k, k + kb - 1
                 if( ipiv( j )>0_${ik}$ ) then
                    ipiv( j ) = ipiv( j ) + k - 1_${ik}$
                 else
                    ipiv( j ) = ipiv( j ) - k + 1_${ik}$
                 end if
              end do
              ! increase k and return to the start of the main loop
              k = k + kb
              go to 20
           end if
           40 continue
           work( 1_${ik}$ ) = lwkopt
           return
     end subroutine stdlib${ii}$_dsytrf_rook

#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ri}$sytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
     !! DSYTRF_ROOK: computes the factorization of a real symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
     !! The form of the factorization is
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, and D is symmetric and block diagonal with
     !! 1-by-1 and 2-by-2 diagonal blocks.
     !! This is the blocked 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, lwork, n
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(${rk}$), intent(inout) :: a(lda,*)
           real(${rk}$), intent(out) :: work(*)
        ! =====================================================================
           ! Local Scalars 
           logical(lk) :: lquery, upper
           integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
           ! Intrinsic Functions 
           ! Executable Statements 
           ! test the input parameters.
           info = 0_${ik}$
           upper = stdlib_lsame( uplo, 'U' )
           lquery = ( lwork==-1_${ik}$ )
           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( lwork<1_${ik}$ .and. .not.lquery ) then
              info = -7_${ik}$
           end if
           if( info==0_${ik}$ ) then
              ! determine the block size
              nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
              lwkopt = max( 1_${ik}$, n*nb )
              work( 1_${ik}$ ) = lwkopt
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSYTRF_ROOK', -info )
              return
           else if( lquery ) then
              return
           end if
           nbmin = 2_${ik}$
           ldwork = n
           if( nb>1_${ik}$ .and. nb<n ) then
              iws = ldwork*nb
              if( lwork<iws ) then
                 nb = max( lwork / ldwork, 1_${ik}$ )
                 nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
              end if
           else
              iws = 1_${ik}$
           end if
           if( nb<nbmin )nb = n
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_${ri}$lasyf_rook;
              ! kb is either nb or nb-1, or k for the last block
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 40
              if( k>nb ) then
                 ! factorize columns k-kb+1:k of a and use blocked code to
                 ! update columns 1:k-kb
                 call stdlib${ii}$_${ri}$lasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
                           
              else
                 ! use unblocked code to factorize columns 1:k of a
                 call stdlib${ii}$_${ri}$sytf2_rook( uplo, k, a, lda, ipiv, iinfo )
                 kb = k
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
              ! no need to adjust ipiv
              ! decrease k and return to the start of the main loop
              k = k - kb
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_${ri}$lasyf_rook;
              ! kb is either nb or nb-1, or n-k+1 for the last block
              k = 1_${ik}$
              20 continue
              ! if k > n, exit from loop
              if( k>n )go to 40
              if( k<=n-nb ) then
                 ! factorize columns k:k+kb-1 of a and use blocked code to
                 ! update columns k+kb:n
                 call stdlib${ii}$_${ri}$lasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
                           ldwork, iinfo )
              else
                 ! use unblocked code to factorize columns k:n of a
                 call stdlib${ii}$_${ri}$sytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
                 kb = n - k + 1_${ik}$
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
              ! adjust ipiv
              do j = k, k + kb - 1
                 if( ipiv( j )>0_${ik}$ ) then
                    ipiv( j ) = ipiv( j ) + k - 1_${ik}$
                 else
                    ipiv( j ) = ipiv( j ) - k + 1_${ik}$
                 end if
              end do
              ! increase k and return to the start of the main loop
              k = k + kb
              go to 20
           end if
           40 continue
           work( 1_${ik}$ ) = lwkopt
           return
     end subroutine stdlib${ii}$_${ri}$sytrf_rook

#:endif
#:endfor

     pure module subroutine stdlib${ii}$_csytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
     !! CSYTRF_ROOK computes the factorization of a complex symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
     !! The form of the factorization is
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, and D is symmetric and block diagonal with
     !! 1-by-1 and 2-by-2 diagonal blocks.
     !! This is the blocked 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, lwork, n
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           complex(sp), intent(inout) :: a(lda,*)
           complex(sp), intent(out) :: work(*)
        ! =====================================================================
           ! Local Scalars 
           logical(lk) :: lquery, upper
           integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
           ! Intrinsic Functions 
           ! Executable Statements 
           ! test the input parameters.
           info = 0_${ik}$
           upper = stdlib_lsame( uplo, 'U' )
           lquery = ( lwork==-1_${ik}$ )
           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( lwork<1_${ik}$ .and. .not.lquery ) then
              info = -7_${ik}$
           end if
           if( info==0_${ik}$ ) then
              ! determine the block size
              nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
              lwkopt = max( 1_${ik}$, n*nb )
              work( 1_${ik}$ ) = lwkopt
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'CSYTRF_ROOK', -info )
              return
           else if( lquery ) then
              return
           end if
           nbmin = 2_${ik}$
           ldwork = n
           if( nb>1_${ik}$ .and. nb<n ) then
              iws = ldwork*nb
              if( lwork<iws ) then
                 nb = max( lwork / ldwork, 1_${ik}$ )
                 nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
              end if
           else
              iws = 1_${ik}$
           end if
           if( nb<nbmin )nb = n
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_clasyf_rook;
              ! kb is either nb or nb-1, or k for the last block
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 40
              if( k>nb ) then
                 ! factorize columns k-kb+1:k of a and use blocked code to
                 ! update columns 1:k-kb
                 call stdlib${ii}$_clasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
                           
              else
                 ! use unblocked code to factorize columns 1:k of a
                 call stdlib${ii}$_csytf2_rook( uplo, k, a, lda, ipiv, iinfo )
                 kb = k
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
              ! no need to adjust ipiv
              ! decrease k and return to the start of the main loop
              k = k - kb
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_clasyf_rook;
              ! kb is either nb or nb-1, or n-k+1 for the last block
              k = 1_${ik}$
              20 continue
              ! if k > n, exit from loop
              if( k>n )go to 40
              if( k<=n-nb ) then
                 ! factorize columns k:k+kb-1 of a and use blocked code to
                 ! update columns k+kb:n
                 call stdlib${ii}$_clasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
                           ldwork, iinfo )
              else
                 ! use unblocked code to factorize columns k:n of a
                 call stdlib${ii}$_csytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
                 kb = n - k + 1_${ik}$
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
              ! adjust ipiv
              do j = k, k + kb - 1
                 if( ipiv( j )>0_${ik}$ ) then
                    ipiv( j ) = ipiv( j ) + k - 1_${ik}$
                 else
                    ipiv( j ) = ipiv( j ) - k + 1_${ik}$
                 end if
              end do
              ! increase k and return to the start of the main loop
              k = k + kb
              go to 20
           end if
           40 continue
           work( 1_${ik}$ ) = lwkopt
           return
     end subroutine stdlib${ii}$_csytrf_rook

     pure module subroutine stdlib${ii}$_zsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
     !! ZSYTRF_ROOK computes the factorization of a complex symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
     !! The form of the factorization is
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, and D is symmetric and block diagonal with
     !! 1-by-1 and 2-by-2 diagonal blocks.
     !! This is the blocked 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, lwork, n
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           complex(dp), intent(inout) :: a(lda,*)
           complex(dp), intent(out) :: work(*)
        ! =====================================================================
           ! Local Scalars 
           logical(lk) :: lquery, upper
           integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
           ! Intrinsic Functions 
           ! Executable Statements 
           ! test the input parameters.
           info = 0_${ik}$
           upper = stdlib_lsame( uplo, 'U' )
           lquery = ( lwork==-1_${ik}$ )
           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( lwork<1_${ik}$ .and. .not.lquery ) then
              info = -7_${ik}$
           end if
           if( info==0_${ik}$ ) then
              ! determine the block size
              nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
              lwkopt = max( 1_${ik}$, n*nb )
              work( 1_${ik}$ ) = lwkopt
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'ZSYTRF_ROOK', -info )
              return
           else if( lquery ) then
              return
           end if
           nbmin = 2_${ik}$
           ldwork = n
           if( nb>1_${ik}$ .and. nb<n ) then
              iws = ldwork*nb
              if( lwork<iws ) then
                 nb = max( lwork / ldwork, 1_${ik}$ )
                 nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
              end if
           else
              iws = 1_${ik}$
           end if
           if( nb<nbmin )nb = n
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_zlasyf_rook;
              ! kb is either nb or nb-1, or k for the last block
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 40
              if( k>nb ) then
                 ! factorize columns k-kb+1:k of a and use blocked code to
                 ! update columns 1:k-kb
                 call stdlib${ii}$_zlasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
                           
              else
                 ! use unblocked code to factorize columns 1:k of a
                 call stdlib${ii}$_zsytf2_rook( uplo, k, a, lda, ipiv, iinfo )
                 kb = k
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
              ! no need to adjust ipiv
              ! decrease k and return to the start of the main loop
              k = k - kb
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_zlasyf_rook;
              ! kb is either nb or nb-1, or n-k+1 for the last block
              k = 1_${ik}$
              20 continue
              ! if k > n, exit from loop
              if( k>n )go to 40
              if( k<=n-nb ) then
                 ! factorize columns k:k+kb-1 of a and use blocked code to
                 ! update columns k+kb:n
                 call stdlib${ii}$_zlasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
                           ldwork, iinfo )
              else
                 ! use unblocked code to factorize columns k:n of a
                 call stdlib${ii}$_zsytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
                 kb = n - k + 1_${ik}$
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
              ! adjust ipiv
              do j = k, k + kb - 1
                 if( ipiv( j )>0_${ik}$ ) then
                    ipiv( j ) = ipiv( j ) + k - 1_${ik}$
                 else
                    ipiv( j ) = ipiv( j ) - k + 1_${ik}$
                 end if
              end do
              ! increase k and return to the start of the main loop
              k = k + kb
              go to 20
           end if
           40 continue
           work( 1_${ik}$ ) = lwkopt
           return
     end subroutine stdlib${ii}$_zsytrf_rook

#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ci}$sytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
     !! ZSYTRF_ROOK: computes the factorization of a complex symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method.
     !! The form of the factorization is
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, and D is symmetric and block diagonal with
     !! 1-by-1 and 2-by-2 diagonal blocks.
     !! This is the blocked 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, lwork, n
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           complex(${ck}$), intent(inout) :: a(lda,*)
           complex(${ck}$), intent(out) :: work(*)
        ! =====================================================================
           ! Local Scalars 
           logical(lk) :: lquery, upper
           integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
           ! Intrinsic Functions 
           ! Executable Statements 
           ! test the input parameters.
           info = 0_${ik}$
           upper = stdlib_lsame( uplo, 'U' )
           lquery = ( lwork==-1_${ik}$ )
           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( lwork<1_${ik}$ .and. .not.lquery ) then
              info = -7_${ik}$
           end if
           if( info==0_${ik}$ ) then
              ! determine the block size
              nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZSYTRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
              lwkopt = max( 1_${ik}$, n*nb )
              work( 1_${ik}$ ) = lwkopt
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'ZSYTRF_ROOK', -info )
              return
           else if( lquery ) then
              return
           end if
           nbmin = 2_${ik}$
           ldwork = n
           if( nb>1_${ik}$ .and. nb<n ) then
              iws = ldwork*nb
              if( lwork<iws ) then
                 nb = max( lwork / ldwork, 1_${ik}$ )
                 nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZSYTRF_ROOK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
              end if
           else
              iws = 1_${ik}$
           end if
           if( nb<nbmin )nb = n
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf_rook;
              ! kb is either nb or nb-1, or k for the last block
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 40
              if( k>nb ) then
                 ! factorize columns k-kb+1:k of a and use blocked code to
                 ! update columns 1:k-kb
                 call stdlib${ii}$_${ci}$lasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo )
                           
              else
                 ! use unblocked code to factorize columns 1:k of a
                 call stdlib${ii}$_${ci}$sytf2_rook( uplo, k, a, lda, ipiv, iinfo )
                 kb = k
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
              ! no need to adjust ipiv
              ! decrease k and return to the start of the main loop
              k = k - kb
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf_rook;
              ! kb is either nb or nb-1, or n-k+1 for the last block
              k = 1_${ik}$
              20 continue
              ! if k > n, exit from loop
              if( k>n )go to 40
              if( k<=n-nb ) then
                 ! factorize columns k:k+kb-1 of a and use blocked code to
                 ! update columns k+kb:n
                 call stdlib${ii}$_${ci}$lasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, &
                           ldwork, iinfo )
              else
                 ! use unblocked code to factorize columns k:n of a
                 call stdlib${ii}$_${ci}$sytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo )
                 kb = n - k + 1_${ik}$
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
              ! adjust ipiv
              do j = k, k + kb - 1
                 if( ipiv( j )>0_${ik}$ ) then
                    ipiv( j ) = ipiv( j ) + k - 1_${ik}$
                 else
                    ipiv( j ) = ipiv( j ) - k + 1_${ik}$
                 end if
              end do
              ! increase k and return to the start of the main loop
              k = k + kb
              go to 20
           end if
           40 continue
           work( 1_${ik}$ ) = lwkopt
           return
     end subroutine stdlib${ii}$_${ci}$sytrf_rook

#:endif
#:endfor



     pure module subroutine stdlib${ii}$_slasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
     !! SLASYF_ROOK computes a partial factorization of a real symmetric
     !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
     !! pivoting method. The partial factorization has the form:
     !! A  =  ( I  U12 ) ( A11  0  ) (  I       0    )  if UPLO = 'U', or:
     !! ( 0  U22 ) (  0   D  ) ( U12**T U22**T )
     !! A  =  ( L11  0 ) (  D   0  ) ( L11**T L21**T )  if UPLO = 'L'
     !! ( L21  I ) (  0  A22 ) (  0       I    )
     !! where the order of D is at most NB. The actual order is returned in
     !! the argument KB, and is either NB or NB-1, or N if N <= NB.
     !! SLASYF_ROOK is an auxiliary routine called by SSYTRF_ROOK. It uses
     !! blocked code (calling Level 3 BLAS) to update the submatrix
     !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
        ! -- lapack computational routine --
        ! -- lapack 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, kb
           integer(${ik}$), intent(in) :: lda, ldw, n, nb
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(sp), intent(inout) :: a(lda,*)
           real(sp), intent(out) :: w(ldw,*)
        ! =====================================================================
           ! Parameters 
           real(sp), parameter :: sevten = 17.0e+0_sp
           
           
           ! Local Scalars 
           logical(lk) :: done
           integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
                     ii
           real(sp) :: absakk, alpha, colmax, d11, d12, d21, d22, stemp, r1, rowmax, t, &
                     sfmin
           ! Intrinsic Functions 
           ! Executable Statements 
           info = 0_${ik}$
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_slamch( 'S' )
           if( stdlib_lsame( uplo, 'U' ) ) then
              ! factorize the trailing columns of a using the upper triangle
              ! of a and working backwards, and compute the matrix w = u12*d
              ! for use in updating a11
              ! k is the main loop index, decreasing from n in steps of 1 or 2
              k = n
              10 continue
              ! kw is the column of w which corresponds to column k of a
              kw = nb + k - n
              ! exit from loop
              if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column kw of w and update it
              call stdlib${ii}$_scopy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
              if( k<n )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', k, n-k, -one, a( 1_${ik}$, k+1 ),lda, w( k, kw+&
                        1_${ik}$ ), ldw, one, w( 1_${ik}$, kw ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( w( k, kw ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_isamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
                 colmax = abs( w( imax, kw ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! copy column imax to column kw-1 of w and update it
                       call stdlib${ii}$_scopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       call stdlib${ii}$_scopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
                                 
                       if( k<n )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', k, n-k, -one,a( 1_${ik}$, k+1 ), lda, &
                                 w( imax, kw+1 ), ldw,one, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_isamax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
                          rowmax = abs( w( jmax, kw-1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_isamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                          stemp = abs( w( itemp, kw-1 ) )
                          if( stemp>rowmax ) then
                             rowmax = stemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! abs( w( imax, kw-1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.(abs( w( imax, kw-1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column kw-1 of w to column kw of w
                          call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k-1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! ============================================================
                 kk = k - kstep + 1_${ik}$
                 ! kkw is the column of w which corresponds to column kk of a
                 kkw = nb + kk - n
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_scopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
                    call stdlib${ii}$_scopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    ! interchange rows k and p in last n-k+1 columns of a
                    ! and last n-k+2 columns of w
                    call stdlib${ii}$_sswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
                    call stdlib${ii}$_sswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
                 end if
                 ! updated column kp is already stored in column kkw of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_scopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
                    call stdlib${ii}$_scopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in last n-kk+1 columns
                    ! of a and w
                    call stdlib${ii}$_sswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
                    call stdlib${ii}$_sswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column kw of w now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    ! store u(k) in column k of a
                    call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
                    if( k>1_${ik}$ ) then
                       if( abs( a( k, k ) )>=sfmin ) then
                          r1 = one / a( k, k )
                          call stdlib${ii}$_sscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
                       else if( a( k, k )/=zero ) then
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
                    ! hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    if( k>2_${ik}$ ) then
                       ! store u(k) and u(k-1) in columns k and k-1 of a
                       d12 = w( k-1, kw )
                       d11 = w( k, kw ) / d12
                       d22 = w( k-1, kw-1 ) / d12
                       t = one / ( d11*d22-one )
                       do j = 1, k - 2
                          a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
                          a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k-1, k-1 ) = w( k-1, kw-1 )
                    a( k-1, k ) = w( k-1, kw )
                    a( k, k ) = w( k, kw )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
              30 continue
              ! update the upper triangle of a11 (= a(1:k,1:k)) as
              ! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
              ! computing blocks of nb columns at a time
              do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
                 jb = min( nb, k-j+1 )
                 ! update the upper triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_sgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, &
                              kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular superdiagonal block
                 if( j>=2_${ik}$ )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( &
                           1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,one, a( 1_${ik}$, j ), lda )
              end do
              ! put u12 in standard form by partially undoing the interchanges
              ! in columns k+1:n
              j = k + 1_${ik}$
              60 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j + 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j + 1_${ik}$
                 if( jp2/=jj .and. j<=n )call stdlib${ii}$_sswap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
                           lda )
                 jj = j - 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_sswap( n-j+1, a( jp1, j ), lda, a( jj, j &
                           ), lda )
              if( j<=n )go to 60
              ! set kb to the number of columns factorized
              kb = n - k
           else
              ! factorize the leading columns of a using the lower triangle
              ! of a and working forwards, and compute the matrix w = l21*d
              ! for use in updating a22
              ! k is the main loop index, increasing from 1 in steps of 1 or 2
              k = 1_${ik}$
              70 continue
              ! exit from loop
              if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column k of w and update it
              call stdlib${ii}$_scopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
              if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( k, &
                        1_${ik}$ ), ldw, one, w( k, k ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( w( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_isamax( n-k, w( k+1, k ), 1_${ik}$ )
                 colmax = abs( w( imax, k ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_scopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    72 continue
                       ! begin pivot search loop body
                       ! copy column imax to column k+1 of w and update it
                       call stdlib${ii}$_scopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
                       call stdlib${ii}$_scopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
                       if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1_${ik}$ ), &
                                 lda, w( imax, 1_${ik}$ ), ldw,one, w( k, k+1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_isamax( imax-k, w( k, k+1 ), 1_${ik}$ )
                          rowmax = abs( w( jmax, k+1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_isamax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
                          stemp = abs( w( itemp, k+1 ) )
                          if( stemp>rowmax ) then
                             rowmax = stemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! abs( w( imax, k+1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.( abs( w( imax, k+1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column k+1 of w to column k of w
                          call stdlib${ii}$_scopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_scopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 72
                 end if
                 ! ============================================================
                 kk = k + kstep - 1_${ik}$
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_scopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
                    call stdlib${ii}$_scopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
                    ! interchange rows k and p in first k columns of a
                    ! and first k+1 columns of w
                    call stdlib${ii}$_sswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
                    call stdlib${ii}$_sswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
                 end if
                 ! updated column kp is already stored in column kk of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_scopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
                    call stdlib${ii}$_scopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in first kk columns of a and w
                    call stdlib${ii}$_sswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
                    call stdlib${ii}$_sswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k of w now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    ! store l(k) in column k of a
                    call stdlib${ii}$_scopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
                    if( k<n ) then
                       if( abs( a( k, k ) )>=sfmin ) then
                          r1 = one / a( k, k )
                          call stdlib${ii}$_sscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
                       else if( a( k, k )/=zero ) then
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    if( k<n-1 ) then
                       ! store l(k) and l(k+1) in columns k and k+1 of a
                       d21 = w( k+1, k )
                       d11 = w( k+1, k+1 ) / d21
                       d22 = w( k, k ) / d21
                       t = one / ( d11*d22-one )
                       do j = k + 2, n
                          a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
                          a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k, k ) = w( k, k )
                    a( k+1, k ) = w( k+1, k )
                    a( k+1, k+1 ) = w( k+1, k+1 )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 70
              90 continue
              ! update the lower triangle of a22 (= a(k:n,k:n)) as
              ! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
              ! computing blocks of nb columns at a time
              do j = k, n, nb
                 jb = min( nb, n-j+1 )
                 ! update the lower triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_sgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1_${ik}$ ), lda, w( jj, &
                              1_${ik}$ ), ldw, one,a( jj, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular subdiagonal block
                 if( j+jb<=n )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
                           one, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,one, a( j+jb, j ), lda )
              end do
              ! put l21 in standard form by partially undoing the interchanges
              ! in columns 1:k-1
              j = k - 1_${ik}$
              120 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j - 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j - 1_${ik}$
                 if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_sswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
                           
                 jj = j + 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_sswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
                           lda )
              if( j>=1 )go to 120
              ! set kb to the number of columns factorized
              kb = k - 1_${ik}$
           end if
           return
     end subroutine stdlib${ii}$_slasyf_rook

     pure module subroutine stdlib${ii}$_dlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
     !! DLASYF_ROOK computes a partial factorization of a real symmetric
     !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
     !! pivoting method. The partial factorization has the form:
     !! A  =  ( I  U12 ) ( A11  0  ) (  I       0    )  if UPLO = 'U', or:
     !! ( 0  U22 ) (  0   D  ) ( U12**T U22**T )
     !! A  =  ( L11  0 ) (  D   0  ) ( L11**T L21**T )  if UPLO = 'L'
     !! ( L21  I ) (  0  A22 ) (  0       I    )
     !! where the order of D is at most NB. The actual order is returned in
     !! the argument KB, and is either NB or NB-1, or N if N <= NB.
     !! DLASYF_ROOK is an auxiliary routine called by DSYTRF_ROOK. It uses
     !! blocked code (calling Level 3 BLAS) to update the submatrix
     !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
        ! -- lapack computational routine --
        ! -- lapack 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, kb
           integer(${ik}$), intent(in) :: lda, ldw, n, nb
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(dp), intent(inout) :: a(lda,*)
           real(dp), intent(out) :: w(ldw,*)
        ! =====================================================================
           ! Parameters 
           real(dp), parameter :: sevten = 17.0e+0_dp
           
           
           ! Local Scalars 
           logical(lk) :: done
           integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
                     ii
           real(dp) :: absakk, alpha, colmax, d11, d12, d21, d22, dtemp, r1, rowmax, t, &
                     sfmin
           ! Intrinsic Functions 
           ! Executable Statements 
           info = 0_${ik}$
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_dlamch( 'S' )
           if( stdlib_lsame( uplo, 'U' ) ) then
              ! factorize the trailing columns of a using the upper triangle
              ! of a and working backwards, and compute the matrix w = u12*d
              ! for use in updating a11
              ! k is the main loop index, decreasing from n in steps of 1 or 2
              k = n
              10 continue
              ! kw is the column of w which corresponds to column k of a
              kw = nb + k - n
              ! exit from loop
              if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column kw of w and update it
              call stdlib${ii}$_dcopy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
              if( k<n )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', k, n-k, -one, a( 1_${ik}$, k+1 ),lda, w( k, kw+&
                        1_${ik}$ ), ldw, one, w( 1_${ik}$, kw ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( w( k, kw ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_idamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
                 colmax = abs( w( imax, kw ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! copy column imax to column kw-1 of w and update it
                       call stdlib${ii}$_dcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       call stdlib${ii}$_dcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
                                 
                       if( k<n )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', k, n-k, -one,a( 1_${ik}$, k+1 ), lda, &
                                 w( imax, kw+1 ), ldw,one, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_idamax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
                          rowmax = abs( w( jmax, kw-1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_idamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                          dtemp = abs( w( itemp, kw-1 ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! abs( w( imax, kw-1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.(abs( w( imax, kw-1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column kw-1 of w to column kw of w
                          call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k-1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! ============================================================
                 kk = k - kstep + 1_${ik}$
                 ! kkw is the column of w which corresponds to column kk of a
                 kkw = nb + kk - n
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_dcopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
                    call stdlib${ii}$_dcopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    ! interchange rows k and p in last n-k+1 columns of a
                    ! and last n-k+2 columns of w
                    call stdlib${ii}$_dswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
                    call stdlib${ii}$_dswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
                 end if
                 ! updated column kp is already stored in column kkw of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_dcopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
                    call stdlib${ii}$_dcopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in last n-kk+1 columns
                    ! of a and w
                    call stdlib${ii}$_dswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
                    call stdlib${ii}$_dswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column kw of w now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    ! store u(k) in column k of a
                    call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
                    if( k>1_${ik}$ ) then
                       if( abs( a( k, k ) )>=sfmin ) then
                          r1 = one / a( k, k )
                          call stdlib${ii}$_dscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
                       else if( a( k, k )/=zero ) then
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
                    ! hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    if( k>2_${ik}$ ) then
                       ! store u(k) and u(k-1) in columns k and k-1 of a
                       d12 = w( k-1, kw )
                       d11 = w( k, kw ) / d12
                       d22 = w( k-1, kw-1 ) / d12
                       t = one / ( d11*d22-one )
                       do j = 1, k - 2
                          a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
                          a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k-1, k-1 ) = w( k-1, kw-1 )
                    a( k-1, k ) = w( k-1, kw )
                    a( k, k ) = w( k, kw )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
              30 continue
              ! update the upper triangle of a11 (= a(1:k,1:k)) as
              ! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
              ! computing blocks of nb columns at a time
              do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
                 jb = min( nb, k-j+1 )
                 ! update the upper triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_dgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, &
                              kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular superdiagonal block
                 if( j>=2_${ik}$ )call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( &
                           1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,one, a( 1_${ik}$, j ), lda )
              end do
              ! put u12 in standard form by partially undoing the interchanges
              ! in columns k+1:n
              j = k + 1_${ik}$
              60 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j + 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j + 1_${ik}$
                 if( jp2/=jj .and. j<=n )call stdlib${ii}$_dswap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
                           lda )
                 jj = j - 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_dswap( n-j+1, a( jp1, j ), lda, a( jj, j &
                           ), lda )
              if( j<=n )go to 60
              ! set kb to the number of columns factorized
              kb = n - k
           else
              ! factorize the leading columns of a using the lower triangle
              ! of a and working forwards, and compute the matrix w = l21*d
              ! for use in updating a22
              ! k is the main loop index, increasing from 1 in steps of 1 or 2
              k = 1_${ik}$
              70 continue
              ! exit from loop
              if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column k of w and update it
              call stdlib${ii}$_dcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
              if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( k, &
                        1_${ik}$ ), ldw, one, w( k, k ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( w( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_idamax( n-k, w( k+1, k ), 1_${ik}$ )
                 colmax = abs( w( imax, k ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_dcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    72 continue
                       ! begin pivot search loop body
                       ! copy column imax to column k+1 of w and update it
                       call stdlib${ii}$_dcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
                       call stdlib${ii}$_dcopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
                       if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1_${ik}$ ), &
                                 lda, w( imax, 1_${ik}$ ), ldw,one, w( k, k+1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_idamax( imax-k, w( k, k+1 ), 1_${ik}$ )
                          rowmax = abs( w( jmax, k+1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_idamax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
                          dtemp = abs( w( itemp, k+1 ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! abs( w( imax, k+1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.( abs( w( imax, k+1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column k+1 of w to column k of w
                          call stdlib${ii}$_dcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_dcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 72
                 end if
                 ! ============================================================
                 kk = k + kstep - 1_${ik}$
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_dcopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
                    call stdlib${ii}$_dcopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
                    ! interchange rows k and p in first k columns of a
                    ! and first k+1 columns of w
                    call stdlib${ii}$_dswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
                    call stdlib${ii}$_dswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
                 end if
                 ! updated column kp is already stored in column kk of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_dcopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
                    call stdlib${ii}$_dcopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in first kk columns of a and w
                    call stdlib${ii}$_dswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
                    call stdlib${ii}$_dswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k of w now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    ! store l(k) in column k of a
                    call stdlib${ii}$_dcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
                    if( k<n ) then
                       if( abs( a( k, k ) )>=sfmin ) then
                          r1 = one / a( k, k )
                          call stdlib${ii}$_dscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
                       else if( a( k, k )/=zero ) then
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    if( k<n-1 ) then
                       ! store l(k) and l(k+1) in columns k and k+1 of a
                       d21 = w( k+1, k )
                       d11 = w( k+1, k+1 ) / d21
                       d22 = w( k, k ) / d21
                       t = one / ( d11*d22-one )
                       do j = k + 2, n
                          a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
                          a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k, k ) = w( k, k )
                    a( k+1, k ) = w( k+1, k )
                    a( k+1, k+1 ) = w( k+1, k+1 )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 70
              90 continue
              ! update the lower triangle of a22 (= a(k:n,k:n)) as
              ! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
              ! computing blocks of nb columns at a time
              do j = k, n, nb
                 jb = min( nb, n-j+1 )
                 ! update the lower triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_dgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1_${ik}$ ), lda, w( jj, &
                              1_${ik}$ ), ldw, one,a( jj, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular subdiagonal block
                 if( j+jb<=n )call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
                           one, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,one, a( j+jb, j ), lda )
              end do
              ! put l21 in standard form by partially undoing the interchanges
              ! in columns 1:k-1
              j = k - 1_${ik}$
              120 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j - 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j - 1_${ik}$
                 if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_dswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
                           
                 jj = j + 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_dswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
                           lda )
              if( j>=1 )go to 120
              ! set kb to the number of columns factorized
              kb = k - 1_${ik}$
           end if
           return
     end subroutine stdlib${ii}$_dlasyf_rook

#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ri}$lasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
     !! DLASYF_ROOK: computes a partial factorization of a real symmetric
     !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
     !! pivoting method. The partial factorization has the form:
     !! A  =  ( I  U12 ) ( A11  0  ) (  I       0    )  if UPLO = 'U', or:
     !! ( 0  U22 ) (  0   D  ) ( U12**T U22**T )
     !! A  =  ( L11  0 ) (  D   0  ) ( L11**T L21**T )  if UPLO = 'L'
     !! ( L21  I ) (  0  A22 ) (  0       I    )
     !! where the order of D is at most NB. The actual order is returned in
     !! the argument KB, and is either NB or NB-1, or N if N <= NB.
     !! DLASYF_ROOK is an auxiliary routine called by DSYTRF_ROOK. It uses
     !! blocked code (calling Level 3 BLAS) to update the submatrix
     !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
        ! -- lapack computational routine --
        ! -- lapack 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, kb
           integer(${ik}$), intent(in) :: lda, ldw, n, nb
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(${rk}$), intent(inout) :: a(lda,*)
           real(${rk}$), intent(out) :: w(ldw,*)
        ! =====================================================================
           ! Parameters 
           real(${rk}$), parameter :: sevten = 17.0e+0_${rk}$
           
           
           ! Local Scalars 
           logical(lk) :: done
           integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
                     ii
           real(${rk}$) :: absakk, alpha, colmax, d11, d12, d21, d22, dtemp, r1, rowmax, t, &
                     sfmin
           ! Intrinsic Functions 
           ! Executable Statements 
           info = 0_${ik}$
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_${ri}$lamch( 'S' )
           if( stdlib_lsame( uplo, 'U' ) ) then
              ! factorize the trailing columns of a using the upper triangle
              ! of a and working backwards, and compute the matrix w = u12*d
              ! for use in updating a11
              ! k is the main loop index, decreasing from n in steps of 1 or 2
              k = n
              10 continue
              ! kw is the column of w which corresponds to column k of a
              kw = nb + k - n
              ! exit from loop
              if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column kw of w and update it
              call stdlib${ii}$_${ri}$copy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
              if( k<n )call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', k, n-k, -one, a( 1_${ik}$, k+1 ),lda, w( k, kw+&
                        1_${ik}$ ), ldw, one, w( 1_${ik}$, kw ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( w( k, kw ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_i${ri}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
                 colmax = abs( w( imax, kw ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_${ri}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! copy column imax to column kw-1 of w and update it
                       call stdlib${ii}$_${ri}$copy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       call stdlib${ii}$_${ri}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
                                 
                       if( k<n )call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', k, n-k, -one,a( 1_${ik}$, k+1 ), lda, &
                                 w( imax, kw+1 ), ldw,one, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_i${ri}$amax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
                          rowmax = abs( w( jmax, kw-1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_i${ri}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                          dtemp = abs( w( itemp, kw-1 ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! abs( w( imax, kw-1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.(abs( w( imax, kw-1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column kw-1 of w to column kw of w
                          call stdlib${ii}$_${ri}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k-1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_${ri}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! ============================================================
                 kk = k - kstep + 1_${ik}$
                 ! kkw is the column of w which corresponds to column kk of a
                 kkw = nb + kk - n
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_${ri}$copy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
                    call stdlib${ii}$_${ri}$copy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    ! interchange rows k and p in last n-k+1 columns of a
                    ! and last n-k+2 columns of w
                    call stdlib${ii}$_${ri}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda )
                    call stdlib${ii}$_${ri}$swap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
                 end if
                 ! updated column kp is already stored in column kkw of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_${ri}$copy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
                    call stdlib${ii}$_${ri}$copy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in last n-kk+1 columns
                    ! of a and w
                    call stdlib${ii}$_${ri}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
                    call stdlib${ii}$_${ri}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column kw of w now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    ! store u(k) in column k of a
                    call stdlib${ii}$_${ri}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
                    if( k>1_${ik}$ ) then
                       if( abs( a( k, k ) )>=sfmin ) then
                          r1 = one / a( k, k )
                          call stdlib${ii}$_${ri}$scal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
                       else if( a( k, k )/=zero ) then
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
                    ! hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    if( k>2_${ik}$ ) then
                       ! store u(k) and u(k-1) in columns k and k-1 of a
                       d12 = w( k-1, kw )
                       d11 = w( k, kw ) / d12
                       d22 = w( k-1, kw-1 ) / d12
                       t = one / ( d11*d22-one )
                       do j = 1, k - 2
                          a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
                          a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k-1, k-1 ) = w( k-1, kw-1 )
                    a( k-1, k ) = w( k-1, kw )
                    a( k, k ) = w( k, kw )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
              30 continue
              ! update the upper triangle of a11 (= a(1:k,1:k)) as
              ! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
              ! computing blocks of nb columns at a time
              do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
                 jb = min( nb, k-j+1 )
                 ! update the upper triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, &
                              kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular superdiagonal block
                 if( j>=2_${ik}$ )call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( &
                           1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,one, a( 1_${ik}$, j ), lda )
              end do
              ! put u12 in standard form by partially undoing the interchanges
              ! in columns k+1:n
              j = k + 1_${ik}$
              60 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j + 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j + 1_${ik}$
                 if( jp2/=jj .and. j<=n )call stdlib${ii}$_${ri}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
                           lda )
                 jj = j - 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_${ri}$swap( n-j+1, a( jp1, j ), lda, a( jj, j &
                           ), lda )
              if( j<=n )go to 60
              ! set kb to the number of columns factorized
              kb = n - k
           else
              ! factorize the leading columns of a using the lower triangle
              ! of a and working forwards, and compute the matrix w = l21*d
              ! for use in updating a22
              ! k is the main loop index, increasing from 1 in steps of 1 or 2
              k = 1_${ik}$
              70 continue
              ! exit from loop
              if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column k of w and update it
              call stdlib${ii}$_${ri}$copy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
              if( k>1_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( k, &
                        1_${ik}$ ), ldw, one, w( k, k ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( w( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_i${ri}$amax( n-k, w( k+1, k ), 1_${ik}$ )
                 colmax = abs( w( imax, k ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_${ri}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    72 continue
                       ! begin pivot search loop body
                       ! copy column imax to column k+1 of w and update it
                       call stdlib${ii}$_${ri}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
                       call stdlib${ii}$_${ri}$copy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
                       if( k>1_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1_${ik}$ ), &
                                 lda, w( imax, 1_${ik}$ ), ldw,one, w( k, k+1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_i${ri}$amax( imax-k, w( k, k+1 ), 1_${ik}$ )
                          rowmax = abs( w( jmax, k+1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_i${ri}$amax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
                          dtemp = abs( w( itemp, k+1 ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! abs( w( imax, k+1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.( abs( w( imax, k+1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column k+1 of w to column k of w
                          call stdlib${ii}$_${ri}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_${ri}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 72
                 end if
                 ! ============================================================
                 kk = k + kstep - 1_${ik}$
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_${ri}$copy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
                    call stdlib${ii}$_${ri}$copy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
                    ! interchange rows k and p in first k columns of a
                    ! and first k+1 columns of w
                    call stdlib${ii}$_${ri}$swap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
                    call stdlib${ii}$_${ri}$swap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
                 end if
                 ! updated column kp is already stored in column kk of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_${ri}$copy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
                    call stdlib${ii}$_${ri}$copy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in first kk columns of a and w
                    call stdlib${ii}$_${ri}$swap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
                    call stdlib${ii}$_${ri}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k of w now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    ! store l(k) in column k of a
                    call stdlib${ii}$_${ri}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
                    if( k<n ) then
                       if( abs( a( k, k ) )>=sfmin ) then
                          r1 = one / a( k, k )
                          call stdlib${ii}$_${ri}$scal( n-k, r1, a( k+1, k ), 1_${ik}$ )
                       else if( a( k, k )/=zero ) then
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    if( k<n-1 ) then
                       ! store l(k) and l(k+1) in columns k and k+1 of a
                       d21 = w( k+1, k )
                       d11 = w( k+1, k+1 ) / d21
                       d22 = w( k, k ) / d21
                       t = one / ( d11*d22-one )
                       do j = k + 2, n
                          a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
                          a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k, k ) = w( k, k )
                    a( k+1, k ) = w( k+1, k )
                    a( k+1, k+1 ) = w( k+1, k+1 )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 70
              90 continue
              ! update the lower triangle of a22 (= a(k:n,k:n)) as
              ! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
              ! computing blocks of nb columns at a time
              do j = k, n, nb
                 jb = min( nb, n-j+1 )
                 ! update the lower triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1_${ik}$ ), lda, w( jj, &
                              1_${ik}$ ), ldw, one,a( jj, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular subdiagonal block
                 if( j+jb<=n )call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
                           one, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,one, a( j+jb, j ), lda )
              end do
              ! put l21 in standard form by partially undoing the interchanges
              ! in columns 1:k-1
              j = k - 1_${ik}$
              120 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j - 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j - 1_${ik}$
                 if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_${ri}$swap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
                           
                 jj = j + 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_${ri}$swap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
                           lda )
              if( j>=1 )go to 120
              ! set kb to the number of columns factorized
              kb = k - 1_${ik}$
           end if
           return
     end subroutine stdlib${ii}$_${ri}$lasyf_rook

#:endif
#:endfor

     pure module subroutine stdlib${ii}$_clasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
     !! CLASYF_ROOK computes a partial factorization of a complex symmetric
     !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
     !! pivoting method. The partial factorization has the form:
     !! A  =  ( I  U12 ) ( A11  0  ) (  I       0    )  if UPLO = 'U', or:
     !! ( 0  U22 ) (  0   D  ) ( U12**T U22**T )
     !! A  =  ( L11  0 ) (  D   0  ) ( L11**T L21**T )  if UPLO = 'L'
     !! ( L21  I ) (  0  A22 ) (  0       I    )
     !! where the order of D is at most NB. The actual order is returned in
     !! the argument KB, and is either NB or NB-1, or N if N <= NB.
     !! CLASYF_ROOK is an auxiliary routine called by CSYTRF_ROOK. It uses
     !! blocked code (calling Level 3 BLAS) to update the submatrix
     !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
        ! -- lapack computational routine --
        ! -- lapack 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, kb
           integer(${ik}$), intent(in) :: lda, ldw, n, nb
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           complex(sp), intent(inout) :: a(lda,*)
           complex(sp), intent(out) :: w(ldw,*)
        ! =====================================================================
           ! Parameters 
           real(sp), parameter :: sevten = 17.0e+0_sp
           
           
           
           ! Local Scalars 
           logical(lk) :: done
           integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
                     ii
           real(sp) :: absakk, alpha, colmax, rowmax, stemp, sfmin
           complex(sp) :: d11, d12, d21, d22, r1, t, z
           ! Intrinsic Functions 
           ! Statement Functions 
           real(sp) :: cabs1
           ! Statement Function Definitions 
           cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) )
           ! Executable Statements 
           info = 0_${ik}$
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_slamch( 'S' )
           if( stdlib_lsame( uplo, 'U' ) ) then
              ! factorize the trailing columns of a using the upper triangle
              ! of a and working backwards, and compute the matrix w = u12*d
              ! for use in updating a11
              ! k is the main loop index, decreasing from n in steps of 1 or 2
              k = n
              10 continue
              ! kw is the column of w which corresponds to column k of a
              kw = nb + k - n
              ! exit from loop
              if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column kw of w and update it
              call stdlib${ii}$_ccopy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
              if( k<n )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', k, n-k, -cone, a( 1_${ik}$, k+1 ),lda, w( k, &
                        kw+1 ), ldw, cone, w( 1_${ik}$, kw ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( w( k, kw ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_icamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
                 colmax = cabs1( w( imax, kw ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! copy column imax to column kw-1 of w and update it
                       call stdlib${ii}$_ccopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       call stdlib${ii}$_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
                                 
                       if( k<n )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', k, n-k, -cone,a( 1_${ik}$, k+1 ), lda,&
                                  w( imax, kw+1 ), ldw,cone, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_icamax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
                          rowmax = cabs1( w( jmax, kw-1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_icamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                          stemp = cabs1( w( itemp, kw-1 ) )
                          if( stemp>rowmax ) then
                             rowmax = stemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! cabs1( w( imax, kw-1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.(cabs1( w( imax, kw-1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column kw-1 of w to column kw of w
                          call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k-1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! ============================================================
                 kk = k - kstep + 1_${ik}$
                 ! kkw is the column of w which corresponds to column kk of a
                 kkw = nb + kk - n
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_ccopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
                    call stdlib${ii}$_ccopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    ! interchange rows k and p in last n-k+1 columns of a
                    ! and last n-k+2 columns of w
                    call stdlib${ii}$_cswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
                    call stdlib${ii}$_cswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
                 end if
                 ! updated column kp is already stored in column kkw of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_ccopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
                    call stdlib${ii}$_ccopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in last n-kk+1 columns
                    ! of a and w
                    call stdlib${ii}$_cswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
                    call stdlib${ii}$_cswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column kw of w now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    ! store u(k) in column k of a
                    call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
                    if( k>1_${ik}$ ) then
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          r1 = cone / a( k, k )
                          call stdlib${ii}$_cscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
                       else if( a( k, k )/=czero ) then
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
                    ! hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    if( k>2_${ik}$ ) then
                       ! store u(k) and u(k-1) in columns k and k-1 of a
                       d12 = w( k-1, kw )
                       d11 = w( k, kw ) / d12
                       d22 = w( k-1, kw-1 ) / d12
                       t = cone / ( d11*d22-cone )
                       do j = 1, k - 2
                          a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
                          a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k-1, k-1 ) = w( k-1, kw-1 )
                    a( k-1, k ) = w( k-1, kw )
                    a( k, k ) = w( k, kw )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
              30 continue
              ! update the upper triangle of a11 (= a(1:k,1:k)) as
              ! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
              ! computing blocks of nb columns at a time
              do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
                 jb = min( nb, k-j+1 )
                 ! update the upper triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,&
                               kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular superdiagonal block
                 if( j>=2_${ik}$ )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( &
                           1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda )
              end do
              ! put u12 in standard form by partially undoing the interchanges
              ! in columns k+1:n
              j = k + 1_${ik}$
              60 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j + 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j + 1_${ik}$
                 if( jp2/=jj .and. j<=n )call stdlib${ii}$_cswap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
                           lda )
                 jj = j - 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_cswap( n-j+1, a( jp1, j ), lda, a( jj, j &
                           ), lda )
              if( j<=n )go to 60
              ! set kb to the number of columns factorized
              kb = n - k
           else
              ! factorize the leading columns of a using the lower triangle
              ! of a and working forwards, and compute the matrix w = l21*d
              ! for use in updating a22
              ! k is the main loop index, increasing from 1 in steps of 1 or 2
              k = 1_${ik}$
              70 continue
              ! exit from loop
              if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column k of w and update it
              call stdlib${ii}$_ccopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
              if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, &
                        1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( w( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_icamax( n-k, w( k+1, k ), 1_${ik}$ )
                 colmax = cabs1( w( imax, k ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    72 continue
                       ! begin pivot search loop body
                       ! copy column imax to column k+1 of w and update it
                       call stdlib${ii}$_ccopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
                       call stdlib${ii}$_ccopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
                       if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), &
                                 lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, w( k, k+1 ), 1_${ik}$ )
                          rowmax = cabs1( w( jmax, k+1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_icamax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
                          stemp = cabs1( w( itemp, k+1 ) )
                          if( stemp>rowmax ) then
                             rowmax = stemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! cabs1( w( imax, k+1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.( cabs1( w( imax, k+1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column k+1 of w to column k of w
                          call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 72
                 end if
                 ! ============================================================
                 kk = k + kstep - 1_${ik}$
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_ccopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
                    call stdlib${ii}$_ccopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
                    ! interchange rows k and p in first k columns of a
                    ! and first k+1 columns of w
                    call stdlib${ii}$_cswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
                    call stdlib${ii}$_cswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
                 end if
                 ! updated column kp is already stored in column kk of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_ccopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
                    call stdlib${ii}$_ccopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in first kk columns of a and w
                    call stdlib${ii}$_cswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
                    call stdlib${ii}$_cswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k of w now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    ! store l(k) in column k of a
                    call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
                    if( k<n ) then
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          r1 = cone / a( k, k )
                          call stdlib${ii}$_cscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
                       else if( a( k, k )/=czero ) then
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    if( k<n-1 ) then
                       ! store l(k) and l(k+1) in columns k and k+1 of a
                       d21 = w( k+1, k )
                       d11 = w( k+1, k+1 ) / d21
                       d22 = w( k, k ) / d21
                       t = cone / ( d11*d22-cone )
                       do j = k + 2, n
                          a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
                          a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k, k ) = w( k, k )
                    a( k+1, k ) = w( k+1, k )
                    a( k+1, k+1 ) = w( k+1, k+1 )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 70
              90 continue
              ! update the lower triangle of a22 (= a(k:n,k:n)) as
              ! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
              ! computing blocks of nb columns at a time
              do j = k, n, nb
                 jb = min( nb, n-j+1 )
                 ! update the lower triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,&
                               1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular subdiagonal block
                 if( j+jb<=n )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
                           cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,cone, a( j+jb, j ), lda )
              end do
              ! put l21 in standard form by partially undoing the interchanges
              ! in columns 1:k-1
              j = k - 1_${ik}$
              120 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j - 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j - 1_${ik}$
                 if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_cswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
                           
                 jj = j + 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_cswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
                           lda )
              if( j>=1 )go to 120
              ! set kb to the number of columns factorized
              kb = k - 1_${ik}$
           end if
           return
     end subroutine stdlib${ii}$_clasyf_rook

     pure module subroutine stdlib${ii}$_zlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
     !! ZLASYF_ROOK computes a partial factorization of a complex symmetric
     !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
     !! pivoting method. The partial factorization has the form:
     !! A  =  ( I  U12 ) ( A11  0  ) (  I       0    )  if UPLO = 'U', or:
     !! ( 0  U22 ) (  0   D  ) ( U12**T U22**T )
     !! A  =  ( L11  0 ) (  D   0  ) ( L11**T L21**T )  if UPLO = 'L'
     !! ( L21  I ) (  0  A22 ) (  0       I    )
     !! where the order of D is at most NB. The actual order is returned in
     !! the argument KB, and is either NB or NB-1, or N if N <= NB.
     !! ZLASYF_ROOK is an auxiliary routine called by ZSYTRF_ROOK. It uses
     !! blocked code (calling Level 3 BLAS) to update the submatrix
     !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
        ! -- lapack computational routine --
        ! -- lapack 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, kb
           integer(${ik}$), intent(in) :: lda, ldw, n, nb
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           complex(dp), intent(inout) :: a(lda,*)
           complex(dp), intent(out) :: w(ldw,*)
        ! =====================================================================
           ! Parameters 
           real(dp), parameter :: sevten = 17.0e+0_dp
           
           
           
           ! Local Scalars 
           logical(lk) :: done
           integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
                     ii
           real(dp) :: absakk, alpha, colmax, rowmax, dtemp, sfmin
           complex(dp) :: d11, d12, d21, d22, r1, t, z
           ! Intrinsic Functions 
           ! Statement Functions 
           real(dp) :: cabs1
           ! Statement Function Definitions 
           cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) )
           ! Executable Statements 
           info = 0_${ik}$
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_dlamch( 'S' )
           if( stdlib_lsame( uplo, 'U' ) ) then
              ! factorize the trailing columns of a using the upper triangle
              ! of a and working backwards, and compute the matrix w = u12*d
              ! for use in updating a11
              ! k is the main loop index, decreasing from n in steps of 1 or 2
              k = n
              10 continue
              ! kw is the column of w which corresponds to column k of a
              kw = nb + k - n
              ! exit from loop
              if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column kw of w and update it
              call stdlib${ii}$_zcopy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
              if( k<n )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', k, n-k, -cone, a( 1_${ik}$, k+1 ),lda, w( k, &
                        kw+1 ), ldw, cone, w( 1_${ik}$, kw ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( w( k, kw ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_izamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
                 colmax = cabs1( w( imax, kw ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! copy column imax to column kw-1 of w and update it
                       call stdlib${ii}$_zcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       call stdlib${ii}$_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
                                 
                       if( k<n )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', k, n-k, -cone,a( 1_${ik}$, k+1 ), lda,&
                                  w( imax, kw+1 ), ldw,cone, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_izamax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
                          rowmax = cabs1( w( jmax, kw-1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_izamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                          dtemp = cabs1( w( itemp, kw-1 ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! cabs1( w( imax, kw-1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.(cabs1( w( imax, kw-1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column kw-1 of w to column kw of w
                          call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k-1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! ============================================================
                 kk = k - kstep + 1_${ik}$
                 ! kkw is the column of w which corresponds to column kk of a
                 kkw = nb + kk - n
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_zcopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
                    call stdlib${ii}$_zcopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    ! interchange rows k and p in last n-k+1 columns of a
                    ! and last n-k+2 columns of w
                    call stdlib${ii}$_zswap( n-k+1, a( k, k ), lda, a( p, k ), lda )
                    call stdlib${ii}$_zswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
                 end if
                 ! updated column kp is already stored in column kkw of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_zcopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
                    call stdlib${ii}$_zcopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in last n-kk+1 columns
                    ! of a and w
                    call stdlib${ii}$_zswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
                    call stdlib${ii}$_zswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column kw of w now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    ! store u(k) in column k of a
                    call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
                    if( k>1_${ik}$ ) then
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          r1 = cone / a( k, k )
                          call stdlib${ii}$_zscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
                       else if( a( k, k )/=czero ) then
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
                    ! hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    if( k>2_${ik}$ ) then
                       ! store u(k) and u(k-1) in columns k and k-1 of a
                       d12 = w( k-1, kw )
                       d11 = w( k, kw ) / d12
                       d22 = w( k-1, kw-1 ) / d12
                       t = cone / ( d11*d22-cone )
                       do j = 1, k - 2
                          a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
                          a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k-1, k-1 ) = w( k-1, kw-1 )
                    a( k-1, k ) = w( k-1, kw )
                    a( k, k ) = w( k, kw )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
              30 continue
              ! update the upper triangle of a11 (= a(1:k,1:k)) as
              ! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
              ! computing blocks of nb columns at a time
              do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
                 jb = min( nb, k-j+1 )
                 ! update the upper triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,&
                               kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular superdiagonal block
                 if( j>=2_${ik}$ )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( &
                           1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda )
              end do
              ! put u12 in standard form by partially undoing the interchanges
              ! in columns k+1:n
              j = k + 1_${ik}$
              60 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j + 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j + 1_${ik}$
                 if( jp2/=jj .and. j<=n )call stdlib${ii}$_zswap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
                           lda )
                 jj = j - 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_zswap( n-j+1, a( jp1, j ), lda, a( jj, j &
                           ), lda )
              if( j<=n )go to 60
              ! set kb to the number of columns factorized
              kb = n - k
           else
              ! factorize the leading columns of a using the lower triangle
              ! of a and working forwards, and compute the matrix w = l21*d
              ! for use in updating a22
              ! k is the main loop index, increasing from 1 in steps of 1 or 2
              k = 1_${ik}$
              70 continue
              ! exit from loop
              if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column k of w and update it
              call stdlib${ii}$_zcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
              if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, &
                        1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( w( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_izamax( n-k, w( k+1, k ), 1_${ik}$ )
                 colmax = cabs1( w( imax, k ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    72 continue
                       ! begin pivot search loop body
                       ! copy column imax to column k+1 of w and update it
                       call stdlib${ii}$_zcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
                       call stdlib${ii}$_zcopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
                       if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), &
                                 lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, w( k, k+1 ), 1_${ik}$ )
                          rowmax = cabs1( w( jmax, k+1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_izamax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
                          dtemp = cabs1( w( itemp, k+1 ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! cabs1( w( imax, k+1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.( cabs1( w( imax, k+1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column k+1 of w to column k of w
                          call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 72
                 end if
                 ! ============================================================
                 kk = k + kstep - 1_${ik}$
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_zcopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
                    call stdlib${ii}$_zcopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
                    ! interchange rows k and p in first k columns of a
                    ! and first k+1 columns of w
                    call stdlib${ii}$_zswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
                    call stdlib${ii}$_zswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
                 end if
                 ! updated column kp is already stored in column kk of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_zcopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
                    call stdlib${ii}$_zcopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in first kk columns of a and w
                    call stdlib${ii}$_zswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
                    call stdlib${ii}$_zswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k of w now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    ! store l(k) in column k of a
                    call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
                    if( k<n ) then
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          r1 = cone / a( k, k )
                          call stdlib${ii}$_zscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
                       else if( a( k, k )/=czero ) then
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    if( k<n-1 ) then
                       ! store l(k) and l(k+1) in columns k and k+1 of a
                       d21 = w( k+1, k )
                       d11 = w( k+1, k+1 ) / d21
                       d22 = w( k, k ) / d21
                       t = cone / ( d11*d22-cone )
                       do j = k + 2, n
                          a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
                          a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k, k ) = w( k, k )
                    a( k+1, k ) = w( k+1, k )
                    a( k+1, k+1 ) = w( k+1, k+1 )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 70
              90 continue
              ! update the lower triangle of a22 (= a(k:n,k:n)) as
              ! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
              ! computing blocks of nb columns at a time
              do j = k, n, nb
                 jb = min( nb, n-j+1 )
                 ! update the lower triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,&
                               1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular subdiagonal block
                 if( j+jb<=n )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
                           cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,cone, a( j+jb, j ), lda )
              end do
              ! put l21 in standard form by partially undoing the interchanges
              ! in columns 1:k-1
              j = k - 1_${ik}$
              120 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j - 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j - 1_${ik}$
                 if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_zswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
                           
                 jj = j + 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_zswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
                           lda )
              if( j>=1 )go to 120
              ! set kb to the number of columns factorized
              kb = k - 1_${ik}$
           end if
           return
     end subroutine stdlib${ii}$_zlasyf_rook

#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ci}$lasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info )
     !! ZLASYF_ROOK: computes a partial factorization of a complex symmetric
     !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal
     !! pivoting method. The partial factorization has the form:
     !! A  =  ( I  U12 ) ( A11  0  ) (  I       0    )  if UPLO = 'U', or:
     !! ( 0  U22 ) (  0   D  ) ( U12**T U22**T )
     !! A  =  ( L11  0 ) (  D   0  ) ( L11**T L21**T )  if UPLO = 'L'
     !! ( L21  I ) (  0  A22 ) (  0       I    )
     !! where the order of D is at most NB. The actual order is returned in
     !! the argument KB, and is either NB or NB-1, or N if N <= NB.
     !! ZLASYF_ROOK is an auxiliary routine called by ZSYTRF_ROOK. It uses
     !! blocked code (calling Level 3 BLAS) to update the submatrix
     !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
        ! -- lapack computational routine --
        ! -- lapack 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, kb
           integer(${ik}$), intent(in) :: lda, ldw, n, nb
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           complex(${ck}$), intent(inout) :: a(lda,*)
           complex(${ck}$), intent(out) :: w(ldw,*)
        ! =====================================================================
           ! Parameters 
           real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$
           
           
           
           ! Local Scalars 
           logical(lk) :: done
           integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, &
                     ii
           real(${ck}$) :: absakk, alpha, colmax, rowmax, dtemp, sfmin
           complex(${ck}$) :: d11, d12, d21, d22, r1, t, z
           ! Intrinsic Functions 
           ! Statement Functions 
           real(${ck}$) :: cabs1
           ! Statement Function Definitions 
           cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) )
           ! Executable Statements 
           info = 0_${ik}$
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
           if( stdlib_lsame( uplo, 'U' ) ) then
              ! factorize the trailing columns of a using the upper triangle
              ! of a and working backwards, and compute the matrix w = u12*d
              ! for use in updating a11
              ! k is the main loop index, decreasing from n in steps of 1 or 2
              k = n
              10 continue
              ! kw is the column of w which corresponds to column k of a
              kw = nb + k - n
              ! exit from loop
              if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column kw of w and update it
              call stdlib${ii}$_${ci}$copy( k, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
              if( k<n )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', k, n-k, -cone, a( 1_${ik}$, k+1 ),lda, w( k, &
                        kw+1 ), ldw, cone, w( 1_${ik}$, kw ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( w( k, kw ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_i${ci}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
                 colmax = cabs1( w( imax, kw ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! copy column imax to column kw-1 of w and update it
                       call stdlib${ii}$_${ci}$copy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       call stdlib${ii}$_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
                                 
                       if( k<n )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', k, n-k, -cone,a( 1_${ik}$, k+1 ), lda,&
                                  w( imax, kw+1 ), ldw,cone, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, w( imax+1, kw-1 ),1_${ik}$ )
                          rowmax = cabs1( w( jmax, kw-1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_i${ci}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
                          dtemp = cabs1( w( itemp, kw-1 ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! cabs1( w( imax, kw-1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.(cabs1( w( imax, kw-1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column kw-1 of w to column kw of w
                          call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k-1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! ============================================================
                 kk = k - kstep + 1_${ik}$
                 ! kkw is the column of w which corresponds to column kk of a
                 kkw = nb + kk - n
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_${ci}$copy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda )
                    call stdlib${ii}$_${ci}$copy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    ! interchange rows k and p in last n-k+1 columns of a
                    ! and last n-k+2 columns of w
                    call stdlib${ii}$_${ci}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda )
                    call stdlib${ii}$_${ci}$swap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw )
                 end if
                 ! updated column kp is already stored in column kkw of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_${ci}$copy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
                    call stdlib${ii}$_${ci}$copy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in last n-kk+1 columns
                    ! of a and w
                    call stdlib${ii}$_${ci}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda )
                    call stdlib${ii}$_${ci}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column kw of w now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    ! store u(k) in column k of a
                    call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
                    if( k>1_${ik}$ ) then
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          r1 = cone / a( k, k )
                          call stdlib${ii}$_${ci}$scal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
                       else if( a( k, k )/=czero ) then
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now
                    ! hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    if( k>2_${ik}$ ) then
                       ! store u(k) and u(k-1) in columns k and k-1 of a
                       d12 = w( k-1, kw )
                       d11 = w( k, kw ) / d12
                       d22 = w( k-1, kw-1 ) / d12
                       t = cone / ( d11*d22-cone )
                       do j = 1, k - 2
                          a( j, k-1 ) = t*( (d11*w( j, kw-1 )-w( j, kw ) ) /d12 )
                          a( j, k ) = t*( ( d22*w( j, kw )-w( j, kw-1 ) ) /d12 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k-1, k-1 ) = w( k-1, kw-1 )
                    a( k-1, k ) = w( k-1, kw )
                    a( k, k ) = w( k, kw )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
              30 continue
              ! update the upper triangle of a11 (= a(1:k,1:k)) as
              ! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
              ! computing blocks of nb columns at a time
              do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
                 jb = min( nb, k-j+1 )
                 ! update the upper triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,&
                               kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular superdiagonal block
                 if( j>=2_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( &
                           1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda )
              end do
              ! put u12 in standard form by partially undoing the interchanges
              ! in columns k+1:n
              j = k + 1_${ik}$
              60 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j + 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j + 1_${ik}$
                 if( jp2/=jj .and. j<=n )call stdlib${ii}$_${ci}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), &
                           lda )
                 jj = j - 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_${ci}$swap( n-j+1, a( jp1, j ), lda, a( jj, j &
                           ), lda )
              if( j<=n )go to 60
              ! set kb to the number of columns factorized
              kb = n - k
           else
              ! factorize the leading columns of a using the lower triangle
              ! of a and working forwards, and compute the matrix w = l21*d
              ! for use in updating a22
              ! k is the main loop index, increasing from 1 in steps of 1 or 2
              k = 1_${ik}$
              70 continue
              ! exit from loop
              if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
              kstep = 1_${ik}$
              p = k
              ! copy column k of a to column k of w and update it
              call stdlib${ii}$_${ci}$copy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
              if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, &
                        1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ )
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( w( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_i${ci}$amax( n-k, w( k+1, k ), 1_${ik}$ )
                 colmax = cabs1( w( imax, k ) )
              else
                 colmax = zero
              end if
              if( max( absakk, colmax )==zero ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
                 call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
              else
                 ! ============================================================
                 ! test for interchange
                 ! equivalent to testing for absakk>=alpha*colmax
                 ! (used to handle nan and inf)
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    72 continue
                       ! begin pivot search loop body
                       ! copy column imax to column k+1 of w and update it
                       call stdlib${ii}$_${ci}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$)
                       call stdlib${ii}$_${ci}$copy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ )
                       if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), &
                                 lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ )
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, w( k, k+1 ), 1_${ik}$ )
                          rowmax = cabs1( w( jmax, k+1 ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_i${ci}$amax( n-imax, w( imax+1, k+1 ), 1_${ik}$)
                          dtemp = cabs1( w( itemp, k+1 ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for
                       ! cabs1( w( imax, k+1 ) )>=alpha*rowmax
                       ! (used to handle nan and inf)
                       if( .not.( cabs1( w( imax, k+1 ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          ! copy column k+1 of w to column k of w
                          call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                          done = .true.
                       ! equivalent to testing for rowmax==colmax,
                       ! (used to handle nan and inf)
                       else if( ( p==jmax ) .or. ( rowmax<=colmax ) )then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found: set params and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                          ! copy updated jmaxth (next imaxth) column to kth of w
                          call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 72
                 end if
                 ! ============================================================
                 kk = k + kstep - 1_${ik}$
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! copy non-updated column k to column p
                    call stdlib${ii}$_${ci}$copy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda )
                    call stdlib${ii}$_${ci}$copy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ )
                    ! interchange rows k and p in first k columns of a
                    ! and first k+1 columns of w
                    call stdlib${ii}$_${ci}$swap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda )
                    call stdlib${ii}$_${ci}$swap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw )
                 end if
                 ! updated column kp is already stored in column kk of w
                 if( kp/=kk ) then
                    ! copy non-updated column kk to column kp
                    a( kp, k ) = a( kk, k )
                    call stdlib${ii}$_${ci}$copy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda )
                    call stdlib${ii}$_${ci}$copy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ )
                    ! interchange rows kk and kp in first kk columns of a and w
                    call stdlib${ii}$_${ci}$swap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
                    call stdlib${ii}$_${ci}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
                 end if
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k of w now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    ! store l(k) in column k of a
                    call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
                    if( k<n ) then
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          r1 = cone / a( k, k )
                          call stdlib${ii}$_${ci}$scal( n-k, r1, a( k+1, k ), 1_${ik}$ )
                       else if( a( k, k )/=czero ) then
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / a( k, k )
                          end do
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    if( k<n-1 ) then
                       ! store l(k) and l(k+1) in columns k and k+1 of a
                       d21 = w( k+1, k )
                       d11 = w( k+1, k+1 ) / d21
                       d22 = w( k, k ) / d21
                       t = cone / ( d11*d22-cone )
                       do j = k + 2, n
                          a( j, k ) = t*( ( d11*w( j, k )-w( j, k+1 ) ) /d21 )
                          a( j, k+1 ) = t*( ( d22*w( j, k+1 )-w( j, k ) ) /d21 )
                       end do
                    end if
                    ! copy d(k) to a
                    a( k, k ) = w( k, k )
                    a( k+1, k ) = w( k+1, k )
                    a( k+1, k+1 ) = w( k+1, k+1 )
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 70
              90 continue
              ! update the lower triangle of a22 (= a(k:n,k:n)) as
              ! a22 := a22 - l21*d*l21**t = a22 - l21*w**t
              ! computing blocks of nb columns at a time
              do j = k, n, nb
                 jb = min( nb, n-j+1 )
                 ! update the lower triangle of the diagonal block
                 do jj = j, j + jb - 1
                    call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,&
                               1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ )
                 end do
                 ! update the rectangular subdiagonal block
                 if( j+jb<=n )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
                           cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,cone, a( j+jb, j ), lda )
              end do
              ! put l21 in standard form by partially undoing the interchanges
              ! in columns 1:k-1
              j = k - 1_${ik}$
              120 continue
                 kstep = 1_${ik}$
                 jp1 = 1_${ik}$
                 jj = j
                 jp2 = ipiv( j )
                 if( jp2<0_${ik}$ ) then
                    jp2 = -jp2
                    j = j - 1_${ik}$
                    jp1 = -ipiv( j )
                    kstep = 2_${ik}$
                 end if
                 j = j - 1_${ik}$
                 if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_${ci}$swap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
                           
                 jj = j + 1_${ik}$
                 if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_${ci}$swap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), &
                           lda )
              if( j>=1 )go to 120
              ! set kb to the number of columns factorized
              kb = k - 1_${ik}$
           end if
           return
     end subroutine stdlib${ii}$_${ci}$lasyf_rook

#:endif
#:endfor



     pure module subroutine stdlib${ii}$_ssytf2_rook( uplo, n, a, lda, ipiv, info )
     !! SSYTF2_ROOK computes the factorization of a real symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, U**T is the transpose of U, and D is symmetric and
     !! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
     !! 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 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(sp), intent(inout) :: a(lda,*)
        ! =====================================================================
           ! Parameters 
           real(sp), parameter :: sevten = 17.0e+0_sp
           
           
           ! Local Scalars 
           logical(lk) :: upper, done
           integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
           real(sp) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, stemp, t, wk, wkm1, &
                     wkp1, sfmin
           ! 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( 'SSYTF2_ROOK', -info )
              return
           end if
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_slamch( 'S' )
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_isamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
                 colmax = abs( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( (max( absakk, colmax )==zero) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange,
                    ! use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_isamax( k-imax, a( imax, imax+1 ),lda )
                          rowmax = abs( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_isamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
                          stemp = abs( a( itemp, imax ) )
                          if( stemp>rowmax ) then
                             rowmax = stemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! abs( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the leading
                    ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
                    if( p>1_${ik}$ )call stdlib${ii}$_sswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    if( p<(k-1) )call stdlib${ii}$_sswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k - kstep + 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the leading
                    ! submatrix a(1:k,1:k)
                    if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_sswap( kk-kp-1, a( kp+1, kk ), &
                              1_${ik}$, a( kp, kp+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k-1, k )
                       a( k-1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the leading submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    if( k>1_${ik}$ ) then
                       ! perform a rank-1 update of a(1:k-1,1:k-1) and
                       ! store u(k) in column k
                       if( abs( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(1:k-1,1:k-1) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*1/d(k)*w(k)**t
                          d11 = one / a( k, k )
                          call stdlib${ii}$_ssyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                          ! store u(k) in column k
                          call stdlib${ii}$_sscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_ssyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k-1 now hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    ! perform a rank-2 update of a(1:k-2,1:k-2) as
                    ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
                       ! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k>2_${ik}$ ) then
                       d12 = a( k-1, k )
                       d22 = a( k-1, k-1 ) / d12
                       d11 = a( k, k ) / d12
                       t = one / ( d11*d22-one )
                       do j = k - 2, 1, -1
                          wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
                          wk = t*( d22*a( j, k )-a( j, k-1 ) )
                          do i = j, 1, -1
                             a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
                                       *wkm1
                          end do
                          ! store u(k) and u(k-1) in cols k and k-1 for row j
                          a( j, k ) = wk / d12
                          a( j, k-1 ) = wkm1 / d12
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop
              if( k>n )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_isamax( n-k, a( k+1, k ), 1_${ik}$ )
                 colmax = abs( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( ( max( absakk, colmax )==zero ) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    42 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_isamax( imax-k, a( imax, k ), lda )
                          rowmax = abs( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_isamax( n-imax, a( imax+1, imax ),1_${ik}$ )
                          stemp = abs( a( itemp, imax ) )
                          if( stemp>rowmax ) then
                             rowmax = stemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! abs( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 42
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the trailing
                    ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
                    if( p<n )call stdlib${ii}$_sswap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
                    if( p>(k+1) )call stdlib${ii}$_sswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k + kstep - 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the trailing
                    ! submatrix a(k:n,k:n)
                    if( kp<n )call stdlib${ii}$_sswap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                              
                    if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_sswap( kp-kk-1, a( kk+1, kk ), &
                              1_${ik}$, a( kp, kk+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k+1, k )
                       a( k+1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the trailing submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    if( k<n ) then
                    ! perform a rank-1 update of a(k+1:n,k+1:n) and
                    ! store l(k) in column k
                       if( abs( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                          d11 = one / a( k, k )
                          call stdlib${ii}$_ssyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                          ! store l(k) in column k
                          call stdlib${ii}$_sscal( n-k, d11, a( k+1, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_ssyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    ! perform a rank-2 update of a(k+2:n,k+2:n) as
                    ! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
                       ! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k<n-1 ) then
                       d21 = a( k+1, k )
                       d11 = a( k+1, k+1 ) / d21
                       d22 = a( k, k ) / d21
                       t = one / ( d11*d22-one )
                       do j = k + 2, n
                          ! compute  d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
                          wk = t*( d11*a( j, k )-a( j, k+1 ) )
                          wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
                          ! perform a rank-2 update of a(k+2:n,k+2:n)
                          do i = j, n
                             a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
                                       *wkp1
                          end do
                          ! store l(k) and l(k+1) in cols k and k+1 for row j
                          a( j, k ) = wk / d21
                          a( j, k+1 ) = wkp1 / d21
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 40
           end if
           70 continue
           return
     end subroutine stdlib${ii}$_ssytf2_rook

     pure module subroutine stdlib${ii}$_dsytf2_rook( uplo, n, a, lda, ipiv, info )
     !! DSYTF2_ROOK computes the factorization of a real symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, U**T is the transpose of U, and D is symmetric and
     !! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
     !! 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 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(dp), intent(inout) :: a(lda,*)
        ! =====================================================================
           ! Parameters 
           real(dp), parameter :: sevten = 17.0e+0_dp
           
           
           ! Local Scalars 
           logical(lk) :: upper, done
           integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
           real(dp) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, dtemp, t, wk, wkm1, &
                     wkp1, sfmin
           ! 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( 'DSYTF2_ROOK', -info )
              return
           end if
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_dlamch( 'S' )
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_idamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
                 colmax = abs( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( (max( absakk, colmax )==zero) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange,
                    ! use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_idamax( k-imax, a( imax, imax+1 ),lda )
                          rowmax = abs( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_idamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
                          dtemp = abs( a( itemp, imax ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! abs( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the leading
                    ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
                    if( p>1_${ik}$ )call stdlib${ii}$_dswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    if( p<(k-1) )call stdlib${ii}$_dswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k - kstep + 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the leading
                    ! submatrix a(1:k,1:k)
                    if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_dswap( kk-kp-1, a( kp+1, kk ), &
                              1_${ik}$, a( kp, kp+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k-1, k )
                       a( k-1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the leading submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    if( k>1_${ik}$ ) then
                       ! perform a rank-1 update of a(1:k-1,1:k-1) and
                       ! store u(k) in column k
                       if( abs( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(1:k-1,1:k-1) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*1/d(k)*w(k)**t
                          d11 = one / a( k, k )
                          call stdlib${ii}$_dsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                          ! store u(k) in column k
                          call stdlib${ii}$_dscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_dsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k-1 now hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    ! perform a rank-2 update of a(1:k-2,1:k-2) as
                    ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
                       ! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k>2_${ik}$ ) then
                       d12 = a( k-1, k )
                       d22 = a( k-1, k-1 ) / d12
                       d11 = a( k, k ) / d12
                       t = one / ( d11*d22-one )
                       do j = k - 2, 1, -1
                          wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
                          wk = t*( d22*a( j, k )-a( j, k-1 ) )
                          do i = j, 1, -1
                             a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
                                       *wkm1
                          end do
                          ! store u(k) and u(k-1) in cols k and k-1 for row j
                          a( j, k ) = wk / d12
                          a( j, k-1 ) = wkm1 / d12
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop
              if( k>n )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_idamax( n-k, a( k+1, k ), 1_${ik}$ )
                 colmax = abs( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( ( max( absakk, colmax )==zero ) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    42 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_idamax( imax-k, a( imax, k ), lda )
                          rowmax = abs( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_idamax( n-imax, a( imax+1, imax ),1_${ik}$ )
                          dtemp = abs( a( itemp, imax ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! abs( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 42
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the trailing
                    ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
                    if( p<n )call stdlib${ii}$_dswap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
                    if( p>(k+1) )call stdlib${ii}$_dswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k + kstep - 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the trailing
                    ! submatrix a(k:n,k:n)
                    if( kp<n )call stdlib${ii}$_dswap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                              
                    if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_dswap( kp-kk-1, a( kk+1, kk ), &
                              1_${ik}$, a( kp, kk+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k+1, k )
                       a( k+1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the trailing submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    if( k<n ) then
                    ! perform a rank-1 update of a(k+1:n,k+1:n) and
                    ! store l(k) in column k
                       if( abs( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                          d11 = one / a( k, k )
                          call stdlib${ii}$_dsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                          ! store l(k) in column k
                          call stdlib${ii}$_dscal( n-k, d11, a( k+1, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_dsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    ! perform a rank-2 update of a(k+2:n,k+2:n) as
                    ! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
                       ! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k<n-1 ) then
                       d21 = a( k+1, k )
                       d11 = a( k+1, k+1 ) / d21
                       d22 = a( k, k ) / d21
                       t = one / ( d11*d22-one )
                       do j = k + 2, n
                          ! compute  d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
                          wk = t*( d11*a( j, k )-a( j, k+1 ) )
                          wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
                          ! perform a rank-2 update of a(k+2:n,k+2:n)
                          do i = j, n
                             a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
                                       *wkp1
                          end do
                          ! store l(k) and l(k+1) in cols k and k+1 for row j
                          a( j, k ) = wk / d21
                          a( j, k+1 ) = wkp1 / d21
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 40
           end if
           70 continue
           return
     end subroutine stdlib${ii}$_dsytf2_rook

#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ri}$sytf2_rook( uplo, n, a, lda, ipiv, info )
     !! DSYTF2_ROOK: computes the factorization of a real symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, U**T is the transpose of U, and D is symmetric and
     !! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
     !! 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 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(${rk}$), intent(inout) :: a(lda,*)
        ! =====================================================================
           ! Parameters 
           real(${rk}$), parameter :: sevten = 17.0e+0_${rk}$
           
           
           ! Local Scalars 
           logical(lk) :: upper, done
           integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
           real(${rk}$) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, dtemp, t, wk, wkm1, &
                     wkp1, sfmin
           ! 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( 'DSYTF2_ROOK', -info )
              return
           end if
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_${ri}$lamch( 'S' )
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_i${ri}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
                 colmax = abs( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( (max( absakk, colmax )==zero) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange,
                    ! use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_i${ri}$amax( k-imax, a( imax, imax+1 ),lda )
                          rowmax = abs( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_i${ri}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
                          dtemp = abs( a( itemp, imax ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! abs( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the leading
                    ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
                    if( p>1_${ik}$ )call stdlib${ii}$_${ri}$swap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    if( p<(k-1) )call stdlib${ii}$_${ri}$swap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k - kstep + 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the leading
                    ! submatrix a(1:k,1:k)
                    if( kp>1_${ik}$ )call stdlib${ii}$_${ri}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_${ri}$swap( kk-kp-1, a( kp+1, kk ), &
                              1_${ik}$, a( kp, kp+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k-1, k )
                       a( k-1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the leading submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    if( k>1_${ik}$ ) then
                       ! perform a rank-1 update of a(1:k-1,1:k-1) and
                       ! store u(k) in column k
                       if( abs( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(1:k-1,1:k-1) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*1/d(k)*w(k)**t
                          d11 = one / a( k, k )
                          call stdlib${ii}$_${ri}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                          ! store u(k) in column k
                          call stdlib${ii}$_${ri}$scal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_${ri}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k-1 now hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    ! perform a rank-2 update of a(1:k-2,1:k-2) as
                    ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
                       ! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k>2_${ik}$ ) then
                       d12 = a( k-1, k )
                       d22 = a( k-1, k-1 ) / d12
                       d11 = a( k, k ) / d12
                       t = one / ( d11*d22-one )
                       do j = k - 2, 1, -1
                          wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
                          wk = t*( d22*a( j, k )-a( j, k-1 ) )
                          do i = j, 1, -1
                             a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
                                       *wkm1
                          end do
                          ! store u(k) and u(k-1) in cols k and k-1 for row j
                          a( j, k ) = wk / d12
                          a( j, k-1 ) = wkm1 / d12
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop
              if( k>n )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = abs( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_i${ri}$amax( n-k, a( k+1, k ), 1_${ik}$ )
                 colmax = abs( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( ( max( absakk, colmax )==zero ) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    42 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_i${ri}$amax( imax-k, a( imax, k ), lda )
                          rowmax = abs( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_i${ri}$amax( n-imax, a( imax+1, imax ),1_${ik}$ )
                          dtemp = abs( a( itemp, imax ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! abs( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( abs( a( imax, imax ) )<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 42
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the trailing
                    ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
                    if( p<n )call stdlib${ii}$_${ri}$swap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
                    if( p>(k+1) )call stdlib${ii}$_${ri}$swap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k + kstep - 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the trailing
                    ! submatrix a(k:n,k:n)
                    if( kp<n )call stdlib${ii}$_${ri}$swap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                              
                    if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_${ri}$swap( kp-kk-1, a( kk+1, kk ), &
                              1_${ik}$, a( kp, kk+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k+1, k )
                       a( k+1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the trailing submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    if( k<n ) then
                    ! perform a rank-1 update of a(k+1:n,k+1:n) and
                    ! store l(k) in column k
                       if( abs( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                          d11 = one / a( k, k )
                          call stdlib${ii}$_${ri}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                          ! store l(k) in column k
                          call stdlib${ii}$_${ri}$scal( n-k, d11, a( k+1, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_${ri}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    ! perform a rank-2 update of a(k+2:n,k+2:n) as
                    ! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
                       ! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k<n-1 ) then
                       d21 = a( k+1, k )
                       d11 = a( k+1, k+1 ) / d21
                       d22 = a( k, k ) / d21
                       t = one / ( d11*d22-one )
                       do j = k + 2, n
                          ! compute  d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
                          wk = t*( d11*a( j, k )-a( j, k+1 ) )
                          wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
                          ! perform a rank-2 update of a(k+2:n,k+2:n)
                          do i = j, n
                             a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
                                       *wkp1
                          end do
                          ! store l(k) and l(k+1) in cols k and k+1 for row j
                          a( j, k ) = wk / d21
                          a( j, k+1 ) = wkp1 / d21
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 40
           end if
           70 continue
           return
     end subroutine stdlib${ii}$_${ri}$sytf2_rook

#:endif
#:endfor

     pure module subroutine stdlib${ii}$_csytf2_rook( uplo, n, a, lda, ipiv, info )
     !! CSYTF2_ROOK computes the factorization of a complex symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, U**T is the transpose of U, and D is symmetric and
     !! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
     !! 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 
           integer(${ik}$), intent(out) :: ipiv(*)
           complex(sp), intent(inout) :: a(lda,*)
        ! =====================================================================
           ! Parameters 
           real(sp), parameter :: sevten = 17.0e+0_sp
           
           
           
           ! Local Scalars 
           logical(lk) :: upper, done
           integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
           real(sp) :: absakk, alpha, colmax, rowmax, stemp, sfmin
           complex(sp) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z
           ! Intrinsic Functions 
           ! Statement Functions 
           real(sp) :: cabs1
           ! Statement Function Definitions 
           cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) )
           ! 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( 'CSYTF2_ROOK', -info )
              return
           end if
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_slamch( 'S' )
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_icamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
                 colmax = cabs1( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( (max( absakk, colmax )==zero) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange,
                    ! use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_icamax( k-imax, a( imax, imax+1 ),lda )
                          rowmax = cabs1( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_icamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
                          stemp = cabs1( a( itemp, imax ) )
                          if( stemp>rowmax ) then
                             rowmax = stemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! cabs1( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the leading
                    ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
                    if( p>1_${ik}$ )call stdlib${ii}$_cswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    if( p<(k-1) )call stdlib${ii}$_cswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k - kstep + 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the leading
                    ! submatrix a(1:k,1:k)
                    if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_cswap( kk-kp-1, a( kp+1, kk ), &
                              1_${ik}$, a( kp, kp+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k-1, k )
                       a( k-1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the leading submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    if( k>1_${ik}$ ) then
                       ! perform a rank-1 update of a(1:k-1,1:k-1) and
                       ! store u(k) in column k
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(1:k-1,1:k-1) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*1/d(k)*w(k)**t
                          d11 = cone / a( k, k )
                          call stdlib${ii}$_csyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                          ! store u(k) in column k
                          call stdlib${ii}$_cscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_csyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k-1 now hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    ! perform a rank-2 update of a(1:k-2,1:k-2) as
                    ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
                       ! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k>2_${ik}$ ) then
                       d12 = a( k-1, k )
                       d22 = a( k-1, k-1 ) / d12
                       d11 = a( k, k ) / d12
                       t = cone / ( d11*d22-cone )
                       do j = k - 2, 1, -1
                          wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
                          wk = t*( d22*a( j, k )-a( j, k-1 ) )
                          do i = j, 1, -1
                             a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
                                       *wkm1
                          end do
                          ! store u(k) and u(k-1) in cols k and k-1 for row j
                          a( j, k ) = wk / d12
                          a( j, k-1 ) = wkm1 / d12
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop
              if( k>n )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_icamax( n-k, a( k+1, k ), 1_${ik}$ )
                 colmax = cabs1( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( ( max( absakk, colmax )==zero ) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    42 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, a( imax, k ), lda )
                          rowmax = cabs1( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_icamax( n-imax, a( imax+1, imax ),1_${ik}$ )
                          stemp = cabs1( a( itemp, imax ) )
                          if( stemp>rowmax ) then
                             rowmax = stemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! cabs1( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 42
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the trailing
                    ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
                    if( p<n )call stdlib${ii}$_cswap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
                    if( p>(k+1) )call stdlib${ii}$_cswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k + kstep - 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the trailing
                    ! submatrix a(k:n,k:n)
                    if( kp<n )call stdlib${ii}$_cswap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                              
                    if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_cswap( kp-kk-1, a( kk+1, kk ), &
                              1_${ik}$, a( kp, kk+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k+1, k )
                       a( k+1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the trailing submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    if( k<n ) then
                    ! perform a rank-1 update of a(k+1:n,k+1:n) and
                    ! store l(k) in column k
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                          d11 = cone / a( k, k )
                          call stdlib${ii}$_csyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                          ! store l(k) in column k
                          call stdlib${ii}$_cscal( n-k, d11, a( k+1, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_csyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    ! perform a rank-2 update of a(k+2:n,k+2:n) as
                    ! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
                       ! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k<n-1 ) then
                       d21 = a( k+1, k )
                       d11 = a( k+1, k+1 ) / d21
                       d22 = a( k, k ) / d21
                       t = cone / ( d11*d22-cone )
                       do j = k + 2, n
                          ! compute  d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
                          wk = t*( d11*a( j, k )-a( j, k+1 ) )
                          wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
                          ! perform a rank-2 update of a(k+2:n,k+2:n)
                          do i = j, n
                             a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
                                       *wkp1
                          end do
                          ! store l(k) and l(k+1) in cols k and k+1 for row j
                          a( j, k ) = wk / d21
                          a( j, k+1 ) = wkp1 / d21
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 40
           end if
           70 continue
           return
     end subroutine stdlib${ii}$_csytf2_rook

     pure module subroutine stdlib${ii}$_zsytf2_rook( uplo, n, a, lda, ipiv, info )
     !! ZSYTF2_ROOK computes the factorization of a complex symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, U**T is the transpose of U, and D is symmetric and
     !! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
     !! 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 
           integer(${ik}$), intent(out) :: ipiv(*)
           complex(dp), intent(inout) :: a(lda,*)
        ! =====================================================================
           ! Parameters 
           real(dp), parameter :: sevten = 17.0e+0_dp
           
           
           
           ! Local Scalars 
           logical(lk) :: upper, done
           integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
           real(dp) :: absakk, alpha, colmax, rowmax, dtemp, sfmin
           complex(dp) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z
           ! Intrinsic Functions 
           ! Statement Functions 
           real(dp) :: cabs1
           ! Statement Function Definitions 
           cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) )
           ! 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( 'ZSYTF2_ROOK', -info )
              return
           end if
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_dlamch( 'S' )
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_izamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
                 colmax = cabs1( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( (max( absakk, colmax )==zero) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange,
                    ! use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_izamax( k-imax, a( imax, imax+1 ),lda )
                          rowmax = cabs1( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_izamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
                          dtemp = cabs1( a( itemp, imax ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! cabs1( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the leading
                    ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
                    if( p>1_${ik}$ )call stdlib${ii}$_zswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    if( p<(k-1) )call stdlib${ii}$_zswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k - kstep + 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the leading
                    ! submatrix a(1:k,1:k)
                    if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_zswap( kk-kp-1, a( kp+1, kk ), &
                              1_${ik}$, a( kp, kp+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k-1, k )
                       a( k-1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the leading submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    if( k>1_${ik}$ ) then
                       ! perform a rank-1 update of a(1:k-1,1:k-1) and
                       ! store u(k) in column k
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(1:k-1,1:k-1) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*1/d(k)*w(k)**t
                          d11 = cone / a( k, k )
                          call stdlib${ii}$_zsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                          ! store u(k) in column k
                          call stdlib${ii}$_zscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_zsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k-1 now hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    ! perform a rank-2 update of a(1:k-2,1:k-2) as
                    ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
                       ! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k>2_${ik}$ ) then
                       d12 = a( k-1, k )
                       d22 = a( k-1, k-1 ) / d12
                       d11 = a( k, k ) / d12
                       t = cone / ( d11*d22-cone )
                       do j = k - 2, 1, -1
                          wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
                          wk = t*( d22*a( j, k )-a( j, k-1 ) )
                          do i = j, 1, -1
                             a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
                                       *wkm1
                          end do
                          ! store u(k) and u(k-1) in cols k and k-1 for row j
                          a( j, k ) = wk / d12
                          a( j, k-1 ) = wkm1 / d12
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop
              if( k>n )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_izamax( n-k, a( k+1, k ), 1_${ik}$ )
                 colmax = cabs1( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( ( max( absakk, colmax )==zero ) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    42 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, a( imax, k ), lda )
                          rowmax = cabs1( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_izamax( n-imax, a( imax+1, imax ),1_${ik}$ )
                          dtemp = cabs1( a( itemp, imax ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! cabs1( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 42
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the trailing
                    ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
                    if( p<n )call stdlib${ii}$_zswap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
                    if( p>(k+1) )call stdlib${ii}$_zswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k + kstep - 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the trailing
                    ! submatrix a(k:n,k:n)
                    if( kp<n )call stdlib${ii}$_zswap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                              
                    if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_zswap( kp-kk-1, a( kk+1, kk ), &
                              1_${ik}$, a( kp, kk+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k+1, k )
                       a( k+1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the trailing submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    if( k<n ) then
                    ! perform a rank-1 update of a(k+1:n,k+1:n) and
                    ! store l(k) in column k
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                          d11 = cone / a( k, k )
                          call stdlib${ii}$_zsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                          ! store l(k) in column k
                          call stdlib${ii}$_zscal( n-k, d11, a( k+1, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_zsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    ! perform a rank-2 update of a(k+2:n,k+2:n) as
                    ! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
                       ! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k<n-1 ) then
                       d21 = a( k+1, k )
                       d11 = a( k+1, k+1 ) / d21
                       d22 = a( k, k ) / d21
                       t = cone / ( d11*d22-cone )
                       do j = k + 2, n
                          ! compute  d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
                          wk = t*( d11*a( j, k )-a( j, k+1 ) )
                          wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
                          ! perform a rank-2 update of a(k+2:n,k+2:n)
                          do i = j, n
                             a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
                                       *wkp1
                          end do
                          ! store l(k) and l(k+1) in cols k and k+1 for row j
                          a( j, k ) = wk / d21
                          a( j, k+1 ) = wkp1 / d21
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 40
           end if
           70 continue
           return
     end subroutine stdlib${ii}$_zsytf2_rook

#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ci}$sytf2_rook( uplo, n, a, lda, ipiv, info )
     !! ZSYTF2_ROOK: computes the factorization of a complex symmetric matrix A
     !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method:
     !! A = U*D*U**T  or  A = L*D*L**T
     !! where U (or L) is a product of permutation and unit upper (lower)
     !! triangular matrices, U**T is the transpose of U, and D is symmetric and
     !! block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
     !! 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 
           integer(${ik}$), intent(out) :: ipiv(*)
           complex(${ck}$), intent(inout) :: a(lda,*)
        ! =====================================================================
           ! Parameters 
           real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$
           
           
           
           ! Local Scalars 
           logical(lk) :: upper, done
           integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii
           real(${ck}$) :: absakk, alpha, colmax, rowmax, dtemp, sfmin
           complex(${ck}$) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z
           ! Intrinsic Functions 
           ! Statement Functions 
           real(${ck}$) :: cabs1
           ! Statement Function Definitions 
           cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) )
           ! 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( 'ZSYTF2_ROOK', -info )
              return
           end if
           ! initialize alpha for use in choosing pivot block size.
           alpha = ( one+sqrt( sevten ) ) / eight
           ! compute machine safe minimum
           sfmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k>1_${ik}$ ) then
                 imax = stdlib${ii}$_i${ci}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
                 colmax = cabs1( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( (max( absakk, colmax )==zero) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange,
                    ! use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    12 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, a( imax, imax+1 ),lda )
                          rowmax = cabs1( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax>1_${ik}$ ) then
                          itemp = stdlib${ii}$_i${ci}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
                          dtemp = cabs1( a( itemp, imax ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! cabs1( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 12
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the leading
                    ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot
                    if( p>1_${ik}$ )call stdlib${ii}$_${ci}$swap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ )
                    if( p<(k-1) )call stdlib${ii}$_${ci}$swap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k - kstep + 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the leading
                    ! submatrix a(1:k,1:k)
                    if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_${ci}$swap( kk-kp-1, a( kp+1, kk ), &
                              1_${ik}$, a( kp, kp+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k-1, k )
                       a( k-1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the leading submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = u(k)*d(k)
                    ! where u(k) is the k-th column of u
                    if( k>1_${ik}$ ) then
                       ! perform a rank-1 update of a(1:k-1,1:k-1) and
                       ! store u(k) in column k
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(1:k-1,1:k-1) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*1/d(k)*w(k)**t
                          d11 = cone / a( k, k )
                          call stdlib${ii}$_${ci}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                          ! store u(k) in column k
                          call stdlib${ii}$_${ci}$scal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = 1, k - 1
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - u(k)*d(k)*u(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_${ci}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k-1 now hold
                    ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
                    ! where u(k) and u(k-1) are the k-th and (k-1)-th columns
                    ! of u
                    ! perform a rank-2 update of a(1:k-2,1:k-2) as
                    ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t
                       ! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k>2_${ik}$ ) then
                       d12 = a( k-1, k )
                       d22 = a( k-1, k-1 ) / d12
                       d11 = a( k, k ) / d12
                       t = cone / ( d11*d22-cone )
                       do j = k - 2, 1, -1
                          wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
                          wk = t*( d22*a( j, k )-a( j, k-1 ) )
                          do i = j, 1, -1
                             a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -( a( i, k-1 ) / d12 )&
                                       *wkm1
                          end do
                          ! store u(k) and u(k-1) in cols k and k-1 for row j
                          a( j, k ) = wk / d12
                          a( j, k-1 ) = wkm1 / d12
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k-1 ) = -kp
              end if
              ! decrease k and return to the start of the main loop
              k = k - kstep
              go to 10
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop
              if( k>n )go to 70
              kstep = 1_${ik}$
              p = k
              ! determine rows and columns to be interchanged and whether
              ! a 1-by-1 or 2-by-2 pivot block will be used
              absakk = cabs1( a( k, k ) )
              ! imax is the row-index of the largest off-diagonal element in
              ! column k, and colmax is its absolute value.
              ! determine both colmax and imax.
              if( k<n ) then
                 imax = k + stdlib${ii}$_i${ci}$amax( n-k, a( k+1, k ), 1_${ik}$ )
                 colmax = cabs1( a( imax, k ) )
              else
                 colmax = zero
              end if
              if( ( max( absakk, colmax )==zero ) ) then
                 ! column k is zero or underflow: set info and continue
                 if( info==0_${ik}$ )info = k
                 kp = k
              else
                 ! test for interchange
                 ! equivalent to testing for (used to handle nan and inf)
                 ! absakk>=alpha*colmax
                 if( .not.( absakk<alpha*colmax ) ) then
                    ! no interchange, use 1-by-1 pivot block
                    kp = k
                 else
                    done = .false.
                    ! loop until pivot found
                    42 continue
                       ! begin pivot search loop body
                       ! jmax is the column-index of the largest off-diagonal
                       ! element in row imax, and rowmax is its absolute value.
                       ! determine both rowmax and jmax.
                       if( imax/=k ) then
                          jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, a( imax, k ), lda )
                          rowmax = cabs1( a( imax, jmax ) )
                       else
                          rowmax = zero
                       end if
                       if( imax<n ) then
                          itemp = imax + stdlib${ii}$_i${ci}$amax( n-imax, a( imax+1, imax ),1_${ik}$ )
                          dtemp = cabs1( a( itemp, imax ) )
                          if( dtemp>rowmax ) then
                             rowmax = dtemp
                             jmax = itemp
                          end if
                       end if
                       ! equivalent to testing for (used to handle nan and inf)
                       ! cabs1( a( imax, imax ) )>=alpha*rowmax
                       if( .not.( cabs1(a( imax, imax ))<alpha*rowmax ) )then
                          ! interchange rows and columns k and imax,
                          ! use 1-by-1 pivot block
                          kp = imax
                          done = .true.
                       ! equivalent to testing for rowmax == colmax,
                       ! used to handle nan and inf
                       else if( ( p==jmax ).or.( rowmax<=colmax ) ) then
                          ! interchange rows and columns k+1 and imax,
                          ! use 2-by-2 pivot block
                          kp = imax
                          kstep = 2_${ik}$
                          done = .true.
                       else
                          ! pivot not found, set variables and repeat
                          p = imax
                          colmax = rowmax
                          imax = jmax
                       end if
                       ! end pivot search loop body
                    if( .not. done ) goto 42
                 end if
                 ! swap two rows and two columns
                 ! first swap
                 if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then
                    ! interchange rows and column k and p in the trailing
                    ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot
                    if( p<n )call stdlib${ii}$_${ci}$swap( n-p, a( p+1, k ), 1_${ik}$, a( p+1, p ), 1_${ik}$ )
                    if( p>(k+1) )call stdlib${ii}$_${ci}$swap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda )
                              
                    t = a( k, k )
                    a( k, k ) = a( p, p )
                    a( p, p ) = t
                 end if
                 ! second swap
                 kk = k + kstep - 1_${ik}$
                 if( kp/=kk ) then
                    ! interchange rows and columns kk and kp in the trailing
                    ! submatrix a(k:n,k:n)
                    if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                              
                    if( ( kk<n ) .and. ( kp>(kk+1) ) )call stdlib${ii}$_${ci}$swap( kp-kk-1, a( kk+1, kk ), &
                              1_${ik}$, a( kp, kk+1 ),lda )
                    t = a( kk, kk )
                    a( kk, kk ) = a( kp, kp )
                    a( kp, kp ) = t
                    if( kstep==2_${ik}$ ) then
                       t = a( k+1, k )
                       a( k+1, k ) = a( kp, k )
                       a( kp, k ) = t
                    end if
                 end if
                 ! update the trailing submatrix
                 if( kstep==1_${ik}$ ) then
                    ! 1-by-1 pivot block d(k): column k now holds
                    ! w(k) = l(k)*d(k)
                    ! where l(k) is the k-th column of l
                    if( k<n ) then
                    ! perform a rank-1 update of a(k+1:n,k+1:n) and
                    ! store l(k) in column k
                       if( cabs1( a( k, k ) )>=sfmin ) then
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                          d11 = cone / a( k, k )
                          call stdlib${ii}$_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                          ! store l(k) in column k
                          call stdlib${ii}$_${ci}$scal( n-k, d11, a( k+1, k ), 1_${ik}$ )
                       else
                          ! store l(k) in column k
                          d11 = a( k, k )
                          do ii = k + 1, n
                             a( ii, k ) = a( ii, k ) / d11
                          end do
                          ! perform a rank-1 update of a(k+1:n,k+1:n) as
                          ! a := a - l(k)*d(k)*l(k)**t
                             ! = a - w(k)*(1/d(k))*w(k)**t
                             ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t
                          call stdlib${ii}$_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
                                    
                       end if
                    end if
                 else
                    ! 2-by-2 pivot block d(k): columns k and k+1 now hold
                    ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
                    ! where l(k) and l(k+1) are the k-th and (k+1)-th columns
                    ! of l
                    ! perform a rank-2 update of a(k+2:n,k+2:n) as
                    ! a := a - ( l(k) l(k+1) ) * d(k) * ( l(k) l(k+1) )**t
                       ! = a - ( ( a(k)a(k+1) )*inv(d(k) ) * ( a(k)a(k+1) )**t
                    ! and store l(k) and l(k+1) in columns k and k+1
                    if( k<n-1 ) then
                       d21 = a( k+1, k )
                       d11 = a( k+1, k+1 ) / d21
                       d22 = a( k, k ) / d21
                       t = cone / ( d11*d22-cone )
                       do j = k + 2, n
                          ! compute  d21 * ( w(k)w(k+1) ) * inv(d(k)) for row j
                          wk = t*( d11*a( j, k )-a( j, k+1 ) )
                          wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
                          ! perform a rank-2 update of a(k+2:n,k+2:n)
                          do i = j, n
                             a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -( a( i, k+1 ) / d21 )&
                                       *wkp1
                          end do
                          ! store l(k) and l(k+1) in cols k and k+1 for row j
                          a( j, k ) = wk / d21
                          a( j, k+1 ) = wkp1 / d21
                       end do
                    end if
                 end if
              end if
              ! store details of the interchanges in ipiv
              if( kstep==1_${ik}$ ) then
                 ipiv( k ) = kp
              else
                 ipiv( k ) = -p
                 ipiv( k+1 ) = -kp
              end if
              ! increase k and return to the start of the main loop
              k = k + kstep
              go to 40
           end if
           70 continue
           return
     end subroutine stdlib${ii}$_${ci}$sytf2_rook

#:endif
#:endfor



     pure module subroutine stdlib${ii}$_ssytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
     !! SSYTRS_ROOK solves a system of linear equations A*X = B with
     !! a real symmetric matrix A using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by SSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(sp), intent(in) :: a(lda,*)
           real(sp), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kp
           real(sp) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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 = -8_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'SSYTRS_ROOK', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_sger( k-1, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_sscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_sswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k>2_${ik}$ ) then
                    call stdlib${ii}$_sger( k-2, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
                              ldb )
                    call stdlib${ii}$_sger( k-2, nrhs, -one, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ),&
                               ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k-1, k )
                 akm1 = a( k-1, k-1 ) / akm1k
                 ak = a( k, k ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t *x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
                           one, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, one, b( &
                              k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, one, &
                              b( k+1, 1_${ik}$ ), ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_sswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_sger( n-k, nrhs, -one, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
                           1_${ik}$, 1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_sscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_sswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_sger( n-k-1, nrhs, -one, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ &
                              ), ldb )
                    call stdlib${ii}$_sger( n-k-1, nrhs, -one, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
                              2_${ik}$, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k+1, k )
                 akm1 = a( k, k ) / akm1k
                 ak = a( k+1, k+1 ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t *x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+&
                           1_${ik}$, k ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k ),&
                               1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-1 &
                              ), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_sswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_ssytrs_rook

     pure module subroutine stdlib${ii}$_dsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
     !! DSYTRS_ROOK solves a system of linear equations A*X = B with
     !! a real symmetric matrix A using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by DSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(dp), intent(in) :: a(lda,*)
           real(dp), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kp
           real(dp) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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 = -8_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSYTRS_ROOK', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_dger( k-1, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_dscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_dswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k>2_${ik}$ ) then
                    call stdlib${ii}$_dger( k-2, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
                              ldb )
                    call stdlib${ii}$_dger( k-2, nrhs, -one, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ),&
                               ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k-1, k )
                 akm1 = a( k-1, k-1 ) / akm1k
                 ak = a( k, k ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t *x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
                           one, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, one, b( &
                              k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, one, &
                              b( k+1, 1_${ik}$ ), ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_dswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_dger( n-k, nrhs, -one, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
                           1_${ik}$, 1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_dscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_dswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_dger( n-k-1, nrhs, -one, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ &
                              ), ldb )
                    call stdlib${ii}$_dger( n-k-1, nrhs, -one, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
                              2_${ik}$, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k+1, k )
                 akm1 = a( k, k ) / akm1k
                 ak = a( k+1, k+1 ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t *x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+&
                           1_${ik}$, k ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k ),&
                               1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-1 &
                              ), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_dswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_dsytrs_rook

#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ri}$sytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
     !! DSYTRS_ROOK: solves a system of linear equations A*X = B with
     !! a real symmetric matrix A using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by DSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(${rk}$), intent(in) :: a(lda,*)
           real(${rk}$), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kp
           real(${rk}$) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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 = -8_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSYTRS_ROOK', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_${ri}$ger( k-1, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
                           
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_${ri}$scal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k>2_${ik}$ ) then
                    call stdlib${ii}$_${ri}$ger( k-2, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
                              ldb )
                    call stdlib${ii}$_${ri}$ger( k-2, nrhs, -one, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ),&
                               ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k-1, k )
                 akm1 = a( k-1, k-1 ) / akm1k
                 ak = a( k, k ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t *x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 if( k>1_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
                           one, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, one, b( &
                              k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, one, &
                              b( k+1, 1_${ik}$ ), ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_${ri}$ger( n-k, nrhs, -one, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
                           1_${ik}$, 1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_${ri}$scal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_${ri}$ger( n-k-1, nrhs, -one, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, 1_${ik}$ &
                              ), ldb )
                    call stdlib${ii}$_${ri}$ger( n-k-1, nrhs, -one, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
                              2_${ik}$, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k+1, k )
                 akm1 = a( k, k ) / akm1k
                 ak = a( k+1, k+1 ) / akm1k
                 denom = akm1*ak - one
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t *x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+&
                           1_${ik}$, k ), 1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k ),&
                               1_${ik}$, one, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k, nrhs, -one, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-1 &
                              ), 1_${ik}$, one, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ri}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_${ri}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_${ri}$sytrs_rook

#:endif
#:endfor

     pure module subroutine stdlib${ii}$_csytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
     !! CSYTRS_ROOK solves a system of linear equations A*X = B with
     !! a complex symmetric matrix A using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by CSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(sp), intent(in) :: a(lda,*)
           complex(sp), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kp
           complex(sp) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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 = -8_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'CSYTRS_ROOK', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_cgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
                           )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_cscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k>2_${ik}$ ) then
                    call stdlib${ii}$_cgeru( k-2, nrhs,-cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
                              ldb )
                    call stdlib${ii}$_cgeru( k-2, nrhs,-cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ )&
                              , ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k-1, k )
                 akm1 = a( k-1, k-1 ) / akm1k
                 ak = a( k, k ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t *x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
                           cone, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, cone, &
                              b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, cone,&
                               b( k+1, 1_${ik}$ ), ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_cgeru( n-k, nrhs, -cone, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( &
                           k+1, 1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_cscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_cgeru( n-k-1, nrhs,-cone, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
                              1_${ik}$ ), ldb )
                    call stdlib${ii}$_cgeru( n-k-1, nrhs,-cone, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
                              2_${ik}$, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k+1, k )
                 akm1 = a( k, k ) / akm1k
                 ak = a( k+1, k+1 ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t *x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+&
                           1_${ik}$, k ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k )&
                              , 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_cgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-&
                              1_${ik}$ ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_csytrs_rook

     pure module subroutine stdlib${ii}$_zsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
     !! ZSYTRS_ROOK solves a system of linear equations A*X = B with
     !! a complex symmetric matrix A using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by ZSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(dp), intent(in) :: a(lda,*)
           complex(dp), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kp
           complex(dp) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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 = -8_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'ZSYTRS_ROOK', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_zgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
                           )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_zscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k>2_${ik}$ ) then
                    call stdlib${ii}$_zgeru( k-2, nrhs,-cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
                              ldb )
                    call stdlib${ii}$_zgeru( k-2, nrhs,-cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ )&
                              , ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k-1, k )
                 akm1 = a( k-1, k-1 ) / akm1k
                 ak = a( k, k ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t *x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
                           cone, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, cone, &
                              b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, cone,&
                               b( k+1, 1_${ik}$ ), ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_zgeru( n-k, nrhs, -cone, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( &
                           k+1, 1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_zscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_zgeru( n-k-1, nrhs,-cone, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
                              1_${ik}$ ), ldb )
                    call stdlib${ii}$_zgeru( n-k-1, nrhs,-cone, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
                              2_${ik}$, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k+1, k )
                 akm1 = a( k, k ) / akm1k
                 ak = a( k+1, k+1 ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t *x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+&
                           1_${ik}$, k ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k )&
                              , 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_zgemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-&
                              1_${ik}$ ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_zsytrs_rook

#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ci}$sytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info )
     !! ZSYTRS_ROOK: solves a system of linear equations A*X = B with
     !! a complex symmetric matrix A using the factorization A = U*D*U**T or
     !! A = L*D*L**T computed by ZSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(${ck}$), intent(in) :: a(lda,*)
           complex(${ck}$), intent(inout) :: b(ldb,*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: j, k, kp
           complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom
           ! Intrinsic Functions 
           ! Executable Statements 
           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 = -8_${ik}$
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'ZSYTRS_ROOK', -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*d*u**t.
              ! first solve u*d*x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              10 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 30
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
                           )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_${ci}$scal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(u(k)), where u(k) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k>2_${ik}$ ) then
                    call stdlib${ii}$_${ci}$geru( k-2, nrhs,-cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
                              ldb )
                    call stdlib${ii}$_${ci}$geru( k-2, nrhs,-cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ )&
                              , ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k-1, k )
                 akm1 = a( k-1, k-1 ) / akm1k
                 ak = a( k, k ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k-1, j ) / akm1k
                    bk = b( k, j ) / akm1k
                    b( k-1, j ) = ( ak*bkm1-bk ) / denom
                    b( k, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k - 2_${ik}$
              end if
              go to 10
              30 continue
              ! next solve u**t *x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              40 continue
              ! if k > n, exit from loop.
              if( k>n )go to 50
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(u**t(k)), where u(k) is the transformation
                 ! stored in column k of a.
                 if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, &
                           cone, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, cone, &
                              b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, cone,&
                               b( k+1, 1_${ik}$ ), ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1).
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k + 2_${ik}$
              end if
              go to 40
              50 continue
           else
              ! solve a*x = b, where a = l*d*l**t.
              ! first solve l*d*x = b, overwriting b with x.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              60 continue
              ! if k > n, exit from loop.
              if( k>n )go to 80
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_${ci}$geru( n-k, nrhs, -cone, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( &
                           k+1, 1_${ik}$ ), ldb )
                 ! multiply by the inverse of the diagonal block.
                 call stdlib${ii}$_${ci}$scal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb )
                 k = k + 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k+1 )
                 if( kp/=k+1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 ! multiply by inv(l(k)), where l(k) is the transformation
                 ! stored in columns k and k+1 of a.
                 if( k<n-1 ) then
                    call stdlib${ii}$_${ci}$geru( n-k-1, nrhs,-cone, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
                              1_${ik}$ ), ldb )
                    call stdlib${ii}$_${ci}$geru( n-k-1, nrhs,-cone, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( k+&
                              2_${ik}$, 1_${ik}$ ), ldb )
                 end if
                 ! multiply by the inverse of the diagonal block.
                 akm1k = a( k+1, k )
                 akm1 = a( k, k ) / akm1k
                 ak = a( k+1, k+1 ) / akm1k
                 denom = akm1*ak - cone
                 do j = 1, nrhs
                    bkm1 = b( k, j ) / akm1k
                    bk = b( k+1, j ) / akm1k
                    b( k, j ) = ( ak*bkm1-bk ) / denom
                    b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
                 end do
                 k = k + 2_${ik}$
              end if
              go to 60
              80 continue
              ! next solve l**t *x = b, overwriting b with x.
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              90 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 100
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! multiply by inv(l**t(k)), where l(k) is the transformation
                 ! stored in column k of a.
                 if( k<n )call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+&
                           1_${ik}$, k ), 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                 ! interchange rows k and ipiv(k).
                 kp = ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! multiply by inv(l**t(k-1)), where l(k-1) is the transformation
                 ! stored in columns k-1 and k of a.
                 if( k<n ) then
                    call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k )&
                              , 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
                    call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', n-k, nrhs, -cone, b( k+1, 1_${ik}$ ),ldb, a( k+1, k-&
                              1_${ik}$ ), 1_${ik}$, cone, b( k-1, 1_${ik}$ ),ldb )
                 end if
                 ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1)
                 kp = -ipiv( k )
                 if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 kp = -ipiv( k-1 )
                 if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
                 k = k - 2_${ik}$
              end if
              go to 90
              100 continue
           end if
           return
     end subroutine stdlib${ii}$_${ci}$sytrs_rook

#:endif
#:endfor



     pure module subroutine stdlib${ii}$_ssytri_rook( uplo, n, a, lda, ipiv, work, info )
     !! SSYTRI_ROOK computes the inverse of a real symmetric
     !! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
     !! computed by SSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(sp), intent(inout) :: a(lda,*)
           real(sp), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: k, kp, kstep
           real(sp) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'SSYTRI_ROOK', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. a( info, info )==zero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do info = 1, n
                 if( ipiv( info )>0 .and. a( info, info )==zero )return
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 40
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = one / a( k, k )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( a( k, k+1 ) )
                 ak = a( k, k ) / t
                 akp1 = a( k+1, k+1 ) / t
                 akkp1 = a( k, k+1 ) / t
                 d = t*( ak*akp1-one )
                 a( k, k ) = akp1 / d
                 a( k+1, k+1 ) = ak / d
                 a( k, k+1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                    a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_sdot( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_sswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k+1 with -ipiv(k) and
                 ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_sswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k+1 )
                    a( k, k+1 ) = a( kp, k+1 )
                    a( kp, k+1 ) = temp
                 end if
                 k = k + 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_sswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k + 1_${ik}$
              go to 30
              40 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              50 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 60
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = one / a( k, k )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_scopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_ssymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
                              k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( a( k, k-1 ) )
                 ak = a( k-1, k-1 ) / t
                 akp1 = a( k, k ) / t
                 akkp1 = a( k, k-1 ) / t
                 d = t*( ak*akp1-one )
                 a( k-1, k-1 ) = akp1 / d
                 a( k, k ) = ak / d
                 a( k, k-1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_scopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_ssymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
                              k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                    a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_sdot( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ )
                              
                    call stdlib${ii}$_scopy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_ssymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
                              k-1 ), 1_${ik}$ )
                    a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_sdot( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_sswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_sswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k-1 with -ipiv(k) and
                 ! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_sswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_sswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k-1 )
                    a( k, k-1 ) = a( kp, k-1 )
                    a( kp, k-1 ) = temp
                 end if
                 k = k - 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_sswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_sswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k - 1_${ik}$
              go to 50
              60 continue
           end if
           return
     end subroutine stdlib${ii}$_ssytri_rook

     pure module subroutine stdlib${ii}$_dsytri_rook( uplo, n, a, lda, ipiv, work, info )
     !! DSYTRI_ROOK computes the inverse of a real symmetric
     !! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
     !! computed by DSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(dp), intent(inout) :: a(lda,*)
           real(dp), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: k, kp, kstep
           real(dp) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'DSYTRI_ROOK', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. a( info, info )==zero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do info = 1, n
                 if( ipiv( info )>0 .and. a( info, info )==zero )return
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 40
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = one / a( k, k )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( a( k, k+1 ) )
                 ak = a( k, k ) / t
                 akp1 = a( k+1, k+1 ) / t
                 akkp1 = a( k, k+1 ) / t
                 d = t*( ak*akp1-one )
                 a( k, k ) = akp1 / d
                 a( k+1, k+1 ) = ak / d
                 a( k, k+1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                    a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_ddot( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_dswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k+1 with -ipiv(k) and
                 ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_dswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k+1 )
                    a( k, k+1 ) = a( kp, k+1 )
                    a( kp, k+1 ) = temp
                 end if
                 k = k + 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_dswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k + 1_${ik}$
              go to 30
              40 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              50 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 60
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = one / a( k, k )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_dcopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dsymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
                              k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( a( k, k-1 ) )
                 ak = a( k-1, k-1 ) / t
                 akp1 = a( k, k ) / t
                 akkp1 = a( k, k-1 ) / t
                 d = t*( ak*akp1-one )
                 a( k-1, k-1 ) = akp1 / d
                 a( k, k ) = ak / d
                 a( k, k-1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_dcopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dsymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
                              k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                    a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_ddot( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ )
                              
                    call stdlib${ii}$_dcopy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_dsymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
                              k-1 ), 1_${ik}$ )
                    a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_ddot( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_dswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_dswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k-1 with -ipiv(k) and
                 ! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_dswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_dswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k-1 )
                    a( k, k-1 ) = a( kp, k-1 )
                    a( kp, k-1 ) = temp
                 end if
                 k = k - 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_dswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_dswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k - 1_${ik}$
              go to 50
              60 continue
           end if
           return
     end subroutine stdlib${ii}$_dsytri_rook

#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ri}$sytri_rook( uplo, n, a, lda, ipiv, work, info )
     !! DSYTRI_ROOK: computes the inverse of a real symmetric
     !! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
     !! computed by DSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           real(${rk}$), intent(inout) :: a(lda,*)
           real(${rk}$), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: k, kp, kstep
           real(${rk}$) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'DSYTRI_ROOK', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. a( info, info )==zero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do info = 1, n
                 if( ipiv( info )>0 .and. a( info, info )==zero )return
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 40
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = one / a( k, k )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_${ri}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$symv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( a( k, k+1 ) )
                 ak = a( k, k ) / t
                 akp1 = a( k+1, k+1 ) / t
                 akkp1 = a( k, k+1 ) / t
                 d = t*( ak*akp1-one )
                 a( k, k ) = akp1 / d
                 a( k+1, k+1 ) = ak / d
                 a( k, k+1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_${ri}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$symv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                    a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_${ri}$dot( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    call stdlib${ii}$_${ri}$copy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$symv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_${ri}$dot( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_${ri}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ri}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k+1 with -ipiv(k) and
                 ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_${ri}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ri}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k+1 )
                    a( k, k+1 ) = a( kp, k+1 )
                    a( kp, k+1 ) = temp
                 end if
                 k = k + 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_${ri}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ri}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k + 1_${ik}$
              go to 30
              40 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              50 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 60
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = one / a( k, k )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_${ri}$copy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$symv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
                              k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = abs( a( k, k-1 ) )
                 ak = a( k-1, k-1 ) / t
                 akp1 = a( k, k ) / t
                 akkp1 = a( k, k-1 ) / t
                 d = t*( ak*akp1-one )
                 a( k-1, k-1 ) = akp1 / d
                 a( k, k ) = ak / d
                 a( k, k-1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_${ri}$copy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$symv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
                              k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                    a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_${ri}$dot( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ )
                              
                    call stdlib${ii}$_${ri}$copy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ri}$symv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1_${ik}$,zero, a( k+1, &
                              k-1 ), 1_${ik}$ )
                    a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_${ri}$dot( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_${ri}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ri}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k-1 with -ipiv(k) and
                 ! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_${ri}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ri}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k-1 )
                    a( k, k-1 ) = a( kp, k-1 )
                    a( kp, k-1 ) = temp
                 end if
                 k = k - 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_${ri}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ri}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k - 1_${ik}$
              go to 50
              60 continue
           end if
           return
     end subroutine stdlib${ii}$_${ri}$sytri_rook

#:endif
#:endfor

     pure module subroutine stdlib${ii}$_csytri_rook( uplo, n, a, lda, ipiv, work, info )
     !! CSYTRI_ROOK computes the inverse of a complex symmetric
     !! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
     !! computed by CSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(sp), intent(inout) :: a(lda,*)
           complex(sp), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: k, kp, kstep
           complex(sp) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'CSYTRI_ROOK', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. a( info, info )==czero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do info = 1, n
                 if( ipiv( info )>0 .and. a( info, info )==czero )return
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 40
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = cone / a( k, k )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = a( k, k+1 )
                 ak = a( k, k ) / t
                 akp1 = a( k+1, k+1 ) / t
                 akkp1 = a( k, k+1 ) / t
                 d = t*( ak*akp1-cone )
                 a( k, k ) = akp1 / d
                 a( k+1, k+1 ) = ak / d
                 a( k, k+1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                    a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_cdotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_cswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k+1 with -ipiv(k) and
                 ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_cswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k+1 )
                    a( k, k+1 ) = a( kp, k+1 )
                    a( kp, k+1 ) = temp
                 end if
                 k = k + 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_cswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k + 1_${ik}$
              go to 30
              40 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              50 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 60
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = cone / a( k, k )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_ccopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_csymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
                               k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = a( k, k-1 )
                 ak = a( k-1, k-1 ) / t
                 akp1 = a( k, k ) / t
                 akkp1 = a( k, k-1 ) / t
                 d = t*( ak*akp1-cone )
                 a( k-1, k-1 ) = akp1 / d
                 a( k, k ) = ak / d
                 a( k, k-1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_ccopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_csymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
                               k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                    a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_cdotu( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ &
                              )
                    call stdlib${ii}$_ccopy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_csymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
                               k-1 ), 1_${ik}$ )
                    a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_cdotu( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_cswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_cswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k-1 with -ipiv(k) and
                 ! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_cswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_cswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k-1 )
                    a( k, k-1 ) = a( kp, k-1 )
                    a( kp, k-1 ) = temp
                 end if
                 k = k - 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_cswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_cswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k - 1_${ik}$
              go to 50
              60 continue
           end if
           return
     end subroutine stdlib${ii}$_csytri_rook

     pure module subroutine stdlib${ii}$_zsytri_rook( uplo, n, a, lda, ipiv, work, info )
     !! ZSYTRI_ROOK computes the inverse of a complex symmetric
     !! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
     !! computed by ZSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(dp), intent(inout) :: a(lda,*)
           complex(dp), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: k, kp, kstep
           complex(dp) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'ZSYTRI_ROOK', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. a( info, info )==czero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do info = 1, n
                 if( ipiv( info )>0 .and. a( info, info )==czero )return
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 40
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = cone / a( k, k )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = a( k, k+1 )
                 ak = a( k, k ) / t
                 akp1 = a( k+1, k+1 ) / t
                 akkp1 = a( k, k+1 ) / t
                 d = t*( ak*akp1-cone )
                 a( k, k ) = akp1 / d
                 a( k+1, k+1 ) = ak / d
                 a( k, k+1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                    a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_zdotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_zswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k+1 with -ipiv(k) and
                 ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_zswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k+1 )
                    a( k, k+1 ) = a( kp, k+1 )
                    a( kp, k+1 ) = temp
                 end if
                 k = k + 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_zswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k + 1_${ik}$
              go to 30
              40 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              50 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 60
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = cone / a( k, k )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_zcopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zsymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
                               k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = a( k, k-1 )
                 ak = a( k-1, k-1 ) / t
                 akp1 = a( k, k ) / t
                 akkp1 = a( k, k-1 ) / t
                 d = t*( ak*akp1-cone )
                 a( k-1, k-1 ) = akp1 / d
                 a( k, k ) = ak / d
                 a( k, k-1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_zcopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zsymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
                               k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                    a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_zdotu( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ &
                              )
                    call stdlib${ii}$_zcopy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_zsymv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
                               k-1 ), 1_${ik}$ )
                    a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_zdotu( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_zswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_zswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k-1 with -ipiv(k) and
                 ! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_zswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_zswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k-1 )
                    a( k, k-1 ) = a( kp, k-1 )
                    a( kp, k-1 ) = temp
                 end if
                 k = k - 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_zswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_zswap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k - 1_${ik}$
              go to 50
              60 continue
           end if
           return
     end subroutine stdlib${ii}$_zsytri_rook

#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ci}$sytri_rook( uplo, n, a, lda, ipiv, work, info )
     !! ZSYTRI_ROOK: computes the inverse of a complex symmetric
     !! matrix A using the factorization A = U*D*U**T or A = L*D*L**T
     !! computed by ZSYTRF_ROOK.
        ! -- lapack computational routine --
        ! -- lapack 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 
           integer(${ik}$), intent(in) :: ipiv(*)
           complex(${ck}$), intent(inout) :: a(lda,*)
           complex(${ck}$), intent(out) :: work(*)
        ! =====================================================================
           
           ! Local Scalars 
           logical(lk) :: upper
           integer(${ik}$) :: k, kp, kstep
           complex(${ck}$) :: ak, akkp1, akp1, d, t, temp
           ! 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( 'ZSYTRI_ROOK', -info )
              return
           end if
           ! quick return if possible
           if( n==0 )return
           ! check that the diagonal matrix d is nonsingular.
           if( upper ) then
              ! upper triangular storage: examine d from bottom to top
              do info = n, 1, -1
                 if( ipiv( info )>0 .and. a( info, info )==czero )return
              end do
           else
              ! lower triangular storage: examine d from top to bottom.
              do info = 1, n
                 if( ipiv( info )>0 .and. a( info, info )==czero )return
              end do
           end if
           info = 0_${ik}$
           if( upper ) then
              ! compute inv(a) from the factorization a = u*d*u**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = 1_${ik}$
              30 continue
              ! if k > n, exit from loop.
              if( k>n )go to 40
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = cone / a( k, k )
                 ! compute column k of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = a( k, k+1 )
                 ak = a( k, k ) / t
                 akp1 = a( k+1, k+1 ) / t
                 akkp1 = a( k, k+1 ) / t
                 d = t*( ak*akp1-cone )
                 a( k, k ) = akp1 / d
                 a( k+1, k+1 ) = ak / d
                 a( k, k+1 ) = -akkp1 / d
                 ! compute columns k and k+1 of the inverse.
                 if( k>1_${ik}$ ) then
                    call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
                              
                    a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ )
                    a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_${ci}$dotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                    a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the leading
                 ! submatrix a(1:k+1,1:k+1)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ci}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k+1 with -ipiv(k) and
                 ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ci}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k+1 )
                    a( k, k+1 ) = a( kp, k+1 )
                    a( kp, k+1 ) = temp
                 end if
                 k = k + 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ci}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k + 1_${ik}$
              go to 30
              40 continue
           else
              ! compute inv(a) from the factorization a = l*d*l**t.
              ! k is the main loop index, increasing from 1 to n in steps of
              ! 1 or 2, depending on the size of the diagonal blocks.
              k = n
              50 continue
              ! if k < 1, exit from loop.
              if( k<1 )go to 60
              if( ipiv( k )>0_${ik}$ ) then
                 ! 1 x 1 diagonal block
                 ! invert the diagonal block.
                 a( k, k ) = cone / a( k, k )
                 ! compute column k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_${ci}$copy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$symv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
                               k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                 end if
                 kstep = 1_${ik}$
              else
                 ! 2 x 2 diagonal block
                 ! invert the diagonal block.
                 t = a( k, k-1 )
                 ak = a( k-1, k-1 ) / t
                 akp1 = a( k, k ) / t
                 akkp1 = a( k, k-1 ) / t
                 d = t*( ak*akp1-cone )
                 a( k-1, k-1 ) = akp1 / d
                 a( k, k ) = ak / d
                 a( k, k-1 ) = -akkp1 / d
                 ! compute columns k-1 and k of the inverse.
                 if( k<n ) then
                    call stdlib${ii}$_${ci}$copy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$symv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
                               k ), 1_${ik}$ )
                    a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, a( k+1, k ),1_${ik}$ )
                    a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_${ci}$dotu( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ &
                              )
                    call stdlib${ii}$_${ci}$copy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
                    call stdlib${ii}$_${ci}$symv( uplo, n-k,-cone, a( k+1, k+1 ), lda, work, 1_${ik}$,czero, a( k+1,&
                               k-1 ), 1_${ik}$ )
                    a( k-1, k-1 ) = a( k-1, k-1 ) -stdlib${ii}$_${ci}$dotu( n-k, work, 1_${ik}$, a( k+1, k-1 ), 1_${ik}$ )
                              
                 end if
                 kstep = 2_${ik}$
              end if
              if( kstep==1_${ik}$ ) then
                 ! interchange rows and columns k and ipiv(k) in the trailing
                 ! submatrix a(k-1:n,k-1:n)
                 kp = ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ci}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              else
                 ! interchange rows and columns k and k-1 with -ipiv(k) and
                 ! -ipiv(k-1) in the trailing submatrix a(k-1:n,k-1:n)
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ci}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                    temp = a( k, k-1 )
                    a( k, k-1 ) = a( kp, k-1 )
                    a( kp, k-1 ) = temp
                 end if
                 k = k - 1_${ik}$
                 kp = -ipiv( k )
                 if( kp/=k ) then
                    if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
                    call stdlib${ii}$_${ci}$swap( kp-k-1, a( k+1, k ), 1_${ik}$, a( kp, k+1 ), lda )
                    temp = a( k, k )
                    a( k, k ) = a( kp, kp )
                    a( kp, kp ) = temp
                 end if
              end if
              k = k - 1_${ik}$
              go to 50
              60 continue
           end if
           return
     end subroutine stdlib${ii}$_${ci}$sytri_rook

#:endif
#:endfor



     pure module subroutine stdlib${ii}$_ssytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info )
     !! SSYTRF_RK computes the factorization of a real symmetric matrix A
     !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
     !! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
     !! where U (or L) is unit upper (or lower) triangular matrix,
     !! U**T (or L**T) is the transpose of U (or L), P is a permutation
     !! matrix, P**T is the transpose of P, and D is symmetric and block
     !! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
     !! This is the blocked version of the algorithm, calling Level 3 BLAS.
     !! For more information see Further Details section.
        ! -- lapack computational routine --
        ! -- lapack 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, lwork, n
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(sp), intent(inout) :: a(lda,*)
           real(sp), intent(out) :: e(*), work(*)
        ! =====================================================================
           ! Local Scalars 
           logical(lk) :: lquery, upper
           integer(${ik}$) :: i, iinfo, ip, iws, k, kb, ldwork, lwkopt, nb, nbmin
           ! Intrinsic Functions 
           ! Executable Statements 
           ! test the input parameters.
           info = 0_${ik}$
           upper = stdlib_lsame( uplo, 'U' )
           lquery = ( lwork==-1_${ik}$ )
           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( lwork<1_${ik}$ .and. .not.lquery ) then
              info = -8_${ik}$
           end if
           if( info==0_${ik}$ ) then
              ! determine the block size
              nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRF_RK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
              lwkopt = n*nb
              work( 1_${ik}$ ) = lwkopt
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'SSYTRF_RK', -info )
              return
           else if( lquery ) then
              return
           end if
           nbmin = 2_${ik}$
           ldwork = n
           if( nb>1_${ik}$ .and. nb<n ) then
              iws = ldwork*nb
              if( lwork<iws ) then
                 nb = max( lwork / ldwork, 1_${ik}$ )
                 nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SSYTRF_RK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
              end if
           else
              iws = 1_${ik}$
           end if
           if( nb<nbmin )nb = n
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf_rk;
              ! kb is either nb or nb-1, or k for the last block
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 15
              if( k>nb ) then
                 ! factorize columns k-kb+1:k of a and use blocked code to
                 ! update columns 1:k-kb
                 call stdlib${ii}$_slasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo )
                           
              else
                 ! use unblocked code to factorize columns 1:k of a
                 call stdlib${ii}$_ssytf2_rk( uplo, k, a, lda, e, ipiv, iinfo )
                 kb = k
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
              ! no need to adjust ipiv
              ! apply permutations to the leading panel 1:k-1
              ! read ipiv from the last block factored, i.e.
              ! indices  k-kb+1:k and apply row permutations to the
              ! last k+1 colunms k+1:n after that block
              ! (we can do the simple loop over ipiv with decrement -1,
              ! since the abs value of ipiv( i ) represents the row index
              ! of the interchange with row i in both 1x1 and 2x2 pivot cases)
              if( k<n ) then
                 do i = k, ( k - kb + 1 ), -1
                    ip = abs( ipiv( i ) )
                    if( ip/=i ) then
                       call stdlib${ii}$_sswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda )
                    end if
                 end do
              end if
              ! decrease k and return to the start of the main loop
              k = k - kb
              go to 10
              ! this label is the exit from main loop over k decreasing
              ! from n to 1 in steps of kb
              15 continue
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf_rk;
              ! kb is either nb or nb-1, or n-k+1 for the last block
              k = 1_${ik}$
              20 continue
              ! if k > n, exit from loop
              if( k>n )go to 35
              if( k<=n-nb ) then
                 ! factorize columns k:k+kb-1 of a and use blocked code to
                 ! update columns k+kb:n
                 call stdlib${ii}$_slasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), &
                           work, ldwork, iinfo )
              else
                 ! use unblocked code to factorize columns k:n of a
                 call stdlib${ii}$_ssytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo )
                           
                 kb = n - k + 1_${ik}$
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
              ! adjust ipiv
              do i = k, k + kb - 1
                 if( ipiv( i )>0_${ik}$ ) then
                    ipiv( i ) = ipiv( i ) + k - 1_${ik}$
                 else
                    ipiv( i ) = ipiv( i ) - k + 1_${ik}$
                 end if
              end do
              ! apply permutations to the leading panel 1:k-1
              ! read ipiv from the last block factored, i.e.
              ! indices  k:k+kb-1 and apply row permutations to the
              ! first k-1 colunms 1:k-1 before that block
              ! (we can do the simple loop over ipiv with increment 1,
              ! since the abs value of ipiv( i ) represents the row index
              ! of the interchange with row i in both 1x1 and 2x2 pivot cases)
              if( k>1_${ik}$ ) then
                 do i = k, ( k + kb - 1 ), 1
                    ip = abs( ipiv( i ) )
                    if( ip/=i ) then
                       call stdlib${ii}$_sswap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
                    end if
                 end do
              end if
              ! increase k and return to the start of the main loop
              k = k + kb
              go to 20
              ! this label is the exit from main loop over k increasing
              ! from 1 to n in steps of kb
              35 continue
           ! end lower
           end if
           work( 1_${ik}$ ) = lwkopt
           return
     end subroutine stdlib${ii}$_ssytrf_rk

     pure module subroutine stdlib${ii}$_dsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info )
     !! DSYTRF_RK computes the factorization of a real symmetric matrix A
     !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
     !! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
     !! where U (or L) is unit upper (or lower) triangular matrix,
     !! U**T (or L**T) is the transpose of U (or L), P is a permutation
     !! matrix, P**T is the transpose of P, and D is symmetric and block
     !! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
     !! This is the blocked version of the algorithm, calling Level 3 BLAS.
     !! For more information see Further Details section.
        ! -- lapack computational routine --
        ! -- lapack 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, lwork, n
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(dp), intent(inout) :: a(lda,*)
           real(dp), intent(out) :: e(*), work(*)
        ! =====================================================================
           ! Local Scalars 
           logical(lk) :: lquery, upper
           integer(${ik}$) :: i, iinfo, ip, iws, k, kb, ldwork, lwkopt, nb, nbmin
           ! Intrinsic Functions 
           ! Executable Statements 
           ! test the input parameters.
           info = 0_${ik}$
           upper = stdlib_lsame( uplo, 'U' )
           lquery = ( lwork==-1_${ik}$ )
           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( lwork<1_${ik}$ .and. .not.lquery ) then
              info = -8_${ik}$
           end if
           if( info==0_${ik}$ ) then
              ! determine the block size
              nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRF_RK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
              lwkopt = n*nb
              work( 1_${ik}$ ) = lwkopt
           end if
           if( info/=0_${ik}$ ) then
              call stdlib${ii}$_xerbla( 'DSYTRF_RK', -info )
              return
           else if( lquery ) then
              return
           end if
           nbmin = 2_${ik}$
           ldwork = n
           if( nb>1_${ik}$ .and. nb<n ) then
              iws = ldwork*nb
              if( lwork<iws ) then
                 nb = max( lwork / ldwork, 1_${ik}$ )
                 nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DSYTRF_RK',uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
              end if
           else
              iws = 1_${ik}$
           end if
           if( nb<nbmin )nb = n
           if( upper ) then
              ! factorize a as u*d*u**t using the upper triangle of a
              ! k is the main loop index, decreasing from n to 1 in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf_rk;
              ! kb is either nb or nb-1, or k for the last block
              k = n
              10 continue
              ! if k < 1, exit from loop
              if( k<1 )go to 15
              if( k>nb ) then
                 ! factorize columns k-kb+1:k of a and use blocked code to
                 ! update columns 1:k-kb
                 call stdlib${ii}$_dlasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo )
                           
              else
                 ! use unblocked code to factorize columns 1:k of a
                 call stdlib${ii}$_dsytf2_rk( uplo, k, a, lda, e, ipiv, iinfo )
                 kb = k
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
              ! no need to adjust ipiv
              ! apply permutations to the leading panel 1:k-1
              ! read ipiv from the last block factored, i.e.
              ! indices  k-kb+1:k and apply row permutations to the
              ! last k+1 colunms k+1:n after that block
              ! (we can do the simple loop over ipiv with decrement -1,
              ! since the abs value of ipiv( i ) represents the row index
              ! of the interchange with row i in both 1x1 and 2x2 pivot cases)
              if( k<n ) then
                 do i = k, ( k - kb + 1 ), -1
                    ip = abs( ipiv( i ) )
                    if( ip/=i ) then
                       call stdlib${ii}$_dswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda )
                    end if
                 end do
              end if
              ! decrease k and return to the start of the main loop
              k = k - kb
              go to 10
              ! this label is the exit from main loop over k decreasing
              ! from n to 1 in steps of kb
              15 continue
           else
              ! factorize a as l*d*l**t using the lower triangle of a
              ! k is the main loop index, increasing from 1 to n in steps of
              ! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf_rk;
              ! kb is either nb or nb-1, or n-k+1 for the last block
              k = 1_${ik}$
              20 continue
              ! if k > n, exit from loop
              if( k>n )go to 35
              if( k<=n-nb ) then
                 ! factorize columns k:k+kb-1 of a and use blocked code to
                 ! update columns k+kb:n
                 call stdlib${ii}$_dlasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), &
                           work, ldwork, iinfo )
              else
                 ! use unblocked code to factorize columns k:n of a
                 call stdlib${ii}$_dsytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo )
                           
                 kb = n - k + 1_${ik}$
              end if
              ! set info on the first occurrence of a zero pivot
              if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
              ! adjust ipiv
              do i = k, k + kb - 1
                 if( ipiv( i )>0_${ik}$ ) then
                    ipiv( i ) = ipiv( i ) + k - 1_${ik}$
                 else
                    ipiv( i ) = ipiv( i ) - k + 1_${ik}$
                 end if
              end do
              ! apply permutations to the leading panel 1:k-1
              ! read ipiv from the last block factored, i.e.
              ! indices  k:k+kb-1 and apply row permutations to the
              ! first k-1 colunms 1:k-1 before that block
              ! (we can do the simple loop over ipiv with increment 1,
              ! since the abs value of ipiv( i ) represents the row index
              ! of the interchange with row i in both 1x1 and 2x2 pivot cases)
              if( k>1_${ik}$ ) then
                 do i = k, ( k + kb - 1 ), 1
                    ip = abs( ipiv( i ) )
                    if( ip/=i ) then
                       call stdlib${ii}$_dswap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda )
                    end if
                 end do
              end if
              ! increase k and return to the start of the main loop
              k = k + kb
              go to 20
              ! this label is the exit from main loop over k increasing
              ! from 1 to n in steps of kb
              35 continue
           ! end lower
           end if
           work( 1_${ik}$ ) = lwkopt
           return
     end subroutine stdlib${ii}$_dsytrf_rk

#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
     pure module subroutine stdlib${ii}$_${ri}$sytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info )
     !! DSYTRF_RK: computes the factorization of a real symmetric matrix A
     !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
     !! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
     !! where U (or L) is unit upper (or lower) triangular matrix,
     !! U**T (or L**T) is the transpose of U (or L), P is a permutation
     !! matrix, P**T is the transpose of P, and D is symmetric and block
     !! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
     !! This is the blocked version of the algorithm, calling Level 3 BLAS.
     !! For more information see Further Details section.
        ! -- lapack computational routine --
        ! -- lapack 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, lwork, n
           ! Array Arguments 
           integer(${ik}$), intent(out) :: ipiv(*)
           real(${rk}$), intent(inout) :: a(lda,*)
           real(${rk}$), intent(